!---------------------------------------------------------------------------- module nemsio_module_mpi !$$$ 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 ! 2010-09-06 Jun Wang change in/out attributes for densewrt ! 2011-10-31 Jun Wang remove bacio, write header from mpiio ! ! Public Variables ! Public Defined Types ! nemsio_gfile ! private ! gtype: character(nemsio_charkind*2) NEMSIO file identifier ! gdatatype:character(nemsio_charkind) data format ! modelname:character(nemsio_charkind) 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*2),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 ! 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 and 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 ! -20 nemsio init ! !$$$ end module document block ! use mpi ! implicit none private !------------------------------------------------------------------------------ ! private variables and type needed by nemsio_gfile integer,parameter:: nemsio_lmeta1=48,nemsio_lmeta3=40 integer,parameter:: nemsio_intkind=4,nemsio_intkind8=8 integer,parameter:: nemsio_realkind=4,nemsio_dblekind=8 integer,parameter:: nemsio_charkind=16,nemsio_charkind8=8, nemsio_charkind4=4 integer,parameter:: nemsio_logickind=4 integer,parameter:: nemsio_maxint=2147483647 real(nemsio_intkind),parameter :: nemsio_intfill=-9999_nemsio_intkind integer(nemsio_intkind8),parameter :: nemsio_intfill8=-9999_nemsio_intkind8 logical(nemsio_logickind),parameter:: nemsio_logicfill=.false. real(nemsio_intkind),parameter :: nemsio_kpds_intfill=-1_nemsio_intkind real(nemsio_realkind),parameter :: nemsio_realfill=-9999._nemsio_realkind real(nemsio_dblekind),parameter :: nemsio_dblefill=-9999._nemsio_dblekind ! !------------------------------------------------------------------------------ !--- public types type,public :: nemsio_gfile private character(nemsio_charkind8) :: gtype=' ' integer(nemsio_intkind):: version=nemsio_intfill character(nemsio_charkind8):: gdatatype=' ' character(nemsio_charkind8):: modelname=' ' integer(nemsio_intkind):: nmeta=nemsio_intfill integer(nemsio_intkind):: lmeta=nemsio_intfill integer(nemsio_intkind):: nrec=nemsio_intfill ! integer(nemsio_intkind):: idate(7)=nemsio_intfill integer(nemsio_intkind):: nfday=nemsio_intfill integer(nemsio_intkind):: nfhour=nemsio_intfill integer(nemsio_intkind):: nfminute=nemsio_intfill integer(nemsio_intkind):: nfsecondn=nemsio_intfill integer(nemsio_intkind):: nfsecondd=nemsio_intfill ! integer(nemsio_intkind):: ifdate(7)=nemsio_intfill ! integer(nemsio_intkind):: dimx=nemsio_intfill integer(nemsio_intkind):: dimy=nemsio_intfill integer(nemsio_intkind):: dimz=nemsio_intfill integer(nemsio_intkind):: nframe=nemsio_intfill integer(nemsio_intkind):: nsoil=nemsio_intfill integer(nemsio_intkind):: ntrac=nemsio_intfill ! integer(nemsio_intkind) :: jcap=nemsio_intfill integer(nemsio_intkind) :: ncldt=nemsio_intfill integer(nemsio_intkind) :: idvc=nemsio_intfill integer(nemsio_intkind) :: idsl=nemsio_intfill integer(nemsio_intkind) :: idvm=nemsio_intfill integer(nemsio_intkind) :: idrt=nemsio_intfill real(nemsio_realkind) :: rlon_min=nemsio_realfill real(nemsio_realkind) :: rlon_max=nemsio_realfill real(nemsio_realkind) :: rlat_min=nemsio_realfill real(nemsio_realkind) :: rlat_max=nemsio_realfill logical(nemsio_logickind) :: extrameta=nemsio_logicfill ! integer(nemsio_intkind):: nmetavari=nemsio_intfill integer(nemsio_intkind):: nmetavarr=nemsio_intfill integer(nemsio_intkind):: nmetavarl=nemsio_intfill integer(nemsio_intkind):: nmetavarc=nemsio_intfill integer(nemsio_intkind):: nmetavarr8=nemsio_intfill integer(nemsio_intkind):: nmetaaryi=nemsio_intfill integer(nemsio_intkind):: nmetaaryr=nemsio_intfill integer(nemsio_intkind):: nmetaaryl=nemsio_intfill integer(nemsio_intkind):: nmetaaryc=nemsio_intfill integer(nemsio_intkind):: nmetaaryr8=nemsio_intfill ! character(nemsio_charkind),allocatable :: recname(:) character(nemsio_charkind),allocatable :: reclevtyp(:) integer(nemsio_intkind),allocatable :: reclev(:) ! real(nemsio_realkind),allocatable :: vcoord(:,:,:) real(nemsio_realkind),allocatable :: lat(:) real(nemsio_realkind),allocatable :: lon(:) real(nemsio_realkind),allocatable :: dx(:) real(nemsio_realkind),allocatable :: dy(:) ! real(nemsio_realkind),allocatable :: Cpi(:) real(nemsio_realkind),allocatable :: Ri(:) ! character(nemsio_charkind),allocatable :: variname(:) integer(nemsio_intkind),allocatable :: varival(:) character(nemsio_charkind),allocatable :: varrname(:) real(nemsio_realkind),allocatable :: varrval(:) character(nemsio_charkind),allocatable :: varr8name(:) real(nemsio_dblekind),allocatable :: varr8val(:) 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(nemsio_intkind),allocatable :: aryilen(:) integer(nemsio_intkind),allocatable :: aryival(:,:) character(nemsio_charkind),allocatable :: aryrname(:) integer(nemsio_intkind),allocatable :: aryrlen(:) real(nemsio_realkind),allocatable :: aryrval(:,:) character(nemsio_charkind),allocatable :: arylname(:) integer(nemsio_intkind),allocatable :: aryllen(:) logical(nemsio_logickind),allocatable :: arylval(:,:) character(nemsio_charkind),allocatable :: arycname(:) integer(nemsio_intkind),allocatable :: aryclen(:) character(nemsio_charkind),allocatable :: arycval(:,:) character(nemsio_charkind),allocatable :: aryr8name(:) integer(nemsio_intkind),allocatable :: aryr8len(:) real(nemsio_dblekind),allocatable :: aryr8val(:,:) ! character(255) :: gfname character(nemsio_charkind8) :: gaction integer(nemsio_intkind8) :: tlmeta=nemsio_intfill integer(nemsio_intkind) :: fieldsize=nemsio_intfill integer(nemsio_intkind) :: flunit=nemsio_intfill integer(nemsio_intkind) :: headvarinum=nemsio_intfill integer(nemsio_intkind) :: headvarrnum=nemsio_intfill integer(nemsio_intkind) :: headvarcnum=nemsio_intfill integer(nemsio_intkind) :: headvarlnum=nemsio_intfill integer(nemsio_intkind) :: headaryinum=nemsio_intfill integer(nemsio_intkind) :: headaryrnum=nemsio_intfill integer(nemsio_intkind) :: 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(nemsio_intkind),allocatable :: headvarival(:) real(nemsio_realkind),allocatable :: headvarrval(:) character(nemsio_charkind),allocatable :: headvarcval(:) logical(nemsio_logickind),allocatable :: headvarlval(:) integer(nemsio_intkind),allocatable :: headaryival(:,:) real(nemsio_realkind),allocatable :: headaryrval(:,:) character(nemsio_charkind),allocatable :: headarycval(:,:) character,allocatable :: cbuf(:) integer(nemsio_intkind):: mbuf=0,nlen,nnum,mnum integer(nemsio_intkind8) :: tlmetalat=nemsio_intfill integer(nemsio_intkind8) :: tlmetalon=nemsio_intfill integer(nemsio_intkind8) :: tlmetadx=nemsio_intfill integer(nemsio_intkind8) :: tlmetady=nemsio_intfill integer(nemsio_intkind8) :: tlmetavarival=nemsio_intfill integer(nemsio_intkind8) :: tlmetaaryival=nemsio_intfill character(16) :: file_endian='' logical :: do_byteswap=.false. !-- for MPI I/O integer(nemsio_intkind) :: mpi_comm=nemsio_intfill integer(nemsio_intkind) :: lead_task=nemsio_intfill integer(nemsio_intkind) :: mype=nemsio_intfill integer(nemsio_intkind) :: npes=nemsio_intfill integer(nemsio_intkind) :: fh=nemsio_intfill real(nemsio_realkind) :: fieldsize_real4=nemsio_realfill real(nemsio_dblekind) :: fieldsize_real8=nemsio_realfill end type nemsio_gfile ! !------------------------------------------------------------------------------ !--- private types ! type :: nemsio_meta1 sequence character(nemsio_charkind8) :: gtype character(nemsio_charkind8) :: modelname character(nemsio_charkind8) :: gdatatype integer(nemsio_intkind) :: version,nmeta,lmeta integer(nemsio_intkind) :: reserve(3) end type nemsio_meta1 ! type :: nemsio_meta2 sequence integer(nemsio_intkind) :: nrec integer(nemsio_intkind) :: idate(1:7),nfday,nfhour,nfminute,nfsecondn, & nfsecondd,dimx,dimy,dimz,nframe,nsoil,ntrac,& jcap,ncldt,idvc,idsl,idvm,idrt real(nemsio_realkind) :: rlon_min,rlon_max,rlat_min,rlat_max logical(nemsio_logickind) :: extrameta end type nemsio_meta2 ! type :: nemsio_meta3 integer(nemsio_intkind) :: nmetavari,nmetavarr,nmetavarl,nmetavarc, & nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc, & nmetavarr8,nmetaaryr8 end type nemsio_meta3 ! character(16) :: machine_endian='big_endian' ! !*** for mpi integer(nemsio_intkind) :: itypemeta1,itypemeta2 ! type :: nemsio_grbmeta integer(nemsio_intkind) :: jf=nemsio_intfill integer(nemsio_intkind) :: j=nemsio_kpds_intfill logical*1,allocatable :: lbms(:) integer(nemsio_intkind) :: jpds(200)=nemsio_kpds_intfill integer(nemsio_intkind) :: jgds(200)=nemsio_kpds_intfill end type nemsio_grbmeta ! !----- interface interface nemsio_getheadvar module procedure nemsio_getfheadvari module procedure nemsio_getfheadvarr module procedure nemsio_getfheadvarl module procedure nemsio_getfheadvarc module procedure nemsio_getfheadvarr8 module procedure nemsio_getfheadaryi module procedure nemsio_getfheadaryr module procedure nemsio_getfheadaryr8 module procedure nemsio_getfheadaryl module procedure nemsio_getfheadaryc end interface nemsio_getheadvar ! interface nemsio_denseread module procedure nemsio_denseread4 module procedure nemsio_denseread8 end interface nemsio_denseread ! interface nemsio_densewrite module procedure nemsio_densewrite4 module procedure nemsio_densewrite8 end interface nemsio_densewrite ! !--- file unit for putgb/getgb ---- integer(nemsio_intkind),save :: fileunit(600:699)=0 !------------------------------------------------------------------------------ !public mehtods public nemsio_intkind,nemsio_intkind8,nemsio_realkind,nemsio_dblekind public nemsio_charkind,nemsio_charkind8,nemsio_logickind public nemsio_init,nemsio_finalize,nemsio_open,nemsio_close public nemsio_denseread,nemsio_densewrite public nemsio_getfilehead,nemsio_getheadvar,nemsio_getrechead ! contains !------------------------------------------------------------------------------- subroutine nemsio_init(iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! initialization !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none integer(nemsio_intkind),optional,intent(out):: iret !-- local vars integer :: meta1_type(2),meta1_block(2),meta1_disp(2) integer :: meta2_type(3),meta2_block(3),meta2_disp(3) integer :: ios ! if (present(iret))iret=1 !------------------------------------------------------------ ! MPI set meta data type !------------------------------------------------------------ ! 1. meta1 meta1_type(1)=MPI_CHARACTER meta1_type(2)=MPI_INTEGER meta1_block(1)=24 meta1_block(2)=6 meta1_disp(1)=0 meta1_disp(2)=meta1_disp(1)+meta1_block(1)*1 call mpi_type_struct(2,meta1_block,meta1_disp,meta1_type, & itypemeta1,ios) call mpi_type_commit(itypemeta1,ios) if ( ios.ne.0 ) then return endif ! ! 2. meta2 meta2_type(1)=MPI_INTEGER meta2_type(2)=MPI_REAL meta2_type(3)=MPI_LOGICAL meta2_block(1)=25 meta2_block(2)=4 meta2_block(3)=1 meta2_disp(1)=0 meta2_disp(2)=meta2_block(1)*4+meta2_disp(1) meta2_disp(3)=meta2_block(2)*4+meta2_disp(2) call mpi_type_struct(3,meta2_block,meta2_disp,meta2_type, & itypemeta2,ios) call mpi_type_commit(itypemeta2,ios) if ( ios.ne.0 ) then return endif ! !------------------------------------------------------------ ! check machine endian !------------------------------------------------------------ call chk_endianc(machine_endian) if(trim(machine_endian)=='mixed_endian') then call nemsio_stop('You are in mixed endian computer,stop!!!') endif ! if(present(iret)) iret=0 ! end subroutine nemsio_init !------------------------------------------------------------------------------ subroutine nemsio_finalize() !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! abstract: finalization !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none !-- end subroutine nemsio_finalize !------------------------------------------------------------------------------ subroutine nemsio_open(gfile,gfname,gaction,mpi_comm, & iret,gdatatype,version,mype,npes, & 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,nmetavarc, & nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc, & nmetavarr8,nmetaaryr8, & recname,reclevtyp,reclev,vcoord,lat,lon,dx,dy,cpi,ri, & variname,varival,varrname,varrval,varlname,varlval,varcname,varcval, & varr8name,varr8val, & aryiname,aryilen,aryival,aryrname,aryrlen,aryrval, & arylname,aryllen,arylval,arycname,aryclen,arycval, & aryr8name,aryr8len,aryr8val ) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! abstract: open nemsio file, and read/write the meta data !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile character*(*),intent(in) :: gfname character*(*),intent(in) :: gaction integer,intent(in) :: mpi_comm !------------------------------------------------------------------------------- ! optional variables !------------------------------------------------------------------------------- integer(nemsio_intkind),optional,intent(out) :: iret character*(*),optional,intent(in) :: gdatatype,modelname integer(nemsio_intkind),optional,intent(in) :: version,nmeta,lmeta,nrec integer,optional,intent(in) :: mype,npes integer(nemsio_intkind),optional,intent(in) :: idate(7),nfday,nfhour, & nfminute, nfsecondn,nfsecondd integer(nemsio_logickind),optional,intent(in):: dimx,dimy,dimz,nframe, & nsoil,ntrac integer(nemsio_logickind),optional,intent(in):: jcap,ncldt,idvc,idsl, & idvm,idrt real(nemsio_realkind),optional,intent(in) :: rlat_min,rlat_max, & rlon_min,rlon_max logical(nemsio_logickind),optional,intent(in):: extrameta integer(nemsio_intkind),optional,intent(in) :: nmetavari,nmetavarr, & nmetavarl,nmetavarc,nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc, & nmetavarr8,nmetaaryr8 ! character*(*),optional,intent(in) :: recname(:),reclevtyp(:) integer(nemsio_intkind),optional,intent(in) :: reclev(:) real(nemsio_realkind),optional,intent(in) :: vcoord(:,:,:) real(nemsio_realkind),optional,intent(in) :: lat(:),lon(:) real(nemsio_realkind),optional,intent(in) :: dx(:),dy(:) real(nemsio_realkind),optional,intent(in) :: Cpi(:),Ri(:) ! character*(*),optional,intent(in) :: variname(:),varrname(:),& varlname(:),varcname(:),varr8name(:),aryiname(:),aryrname(:), & arylname(:),arycname(:),aryr8name(:) integer(nemsio_intkind),optional,intent(in) :: aryilen(:),aryrlen(:), & aryllen(:),aryclen(:),aryr8len(:) integer(nemsio_intkind),optional,intent(in) :: varival(:),aryival(:,:) real(nemsio_realkind),optional,intent(in) :: varrval(:),aryrval(:,:) real(nemsio_dblekind),optional,intent(in) :: varr8val(:),aryr8val(:,:) logical(nemsio_logickind),optional,intent(in):: varlval(:),arylval(:,:) character(*),optional,intent(in) :: varcval(:),arycval(:,:) ! integer :: ios !------------------------------------------------------------ !### for MPI IO, just need this part for read header ###### ! assign a unit number !------------------------------------------------------------ if (present(iret)) iret=-1 ! gfile%gfname=gfname gfile%gaction=gaction gfile%mpi_comm=mpi_comm gfile%lead_task=0 ! if(present(mype)) then gfile%mype=mype else call mpi_comm_rank(mpi_comm,gfile%mype,ios) if ( ios.ne.0 ) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif endif if(present(npes)) then gfile%npes=npes else call mpi_comm_size(mpi_comm,gfile%npes,ios) if ( ios.ne.0 ) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif endif ! !------------------------------------------------------------ ! open and read meta data for READ !------------------------------------------------------------ if ( equal_str_nocase(trim(gaction),"read").or. & equal_str_nocase(trim(gaction),"rdwr") )then ! !-read 2D field using MPI I/O ! if(equal_str_nocase(trim(gaction),"read")) then call mpi_file_open(mpi_comm,gfname,MPI_MODE_RDONLY,MPI_INFO_NULL,gfile%fh,ios) else if(equal_str_nocase(trim(gaction),"rdwt")) then call mpi_file_open(mpi_comm,gfname,MPI_MODE_RDWR,MPI_INFO_NULL,gfile%fh,ios) endif if ( ios.ne.0) then if ( present(iret)) then return else call nemsio_stop endif endif ! !-read meta data for gfile, use non-mpi read for header ! call nemsio_rcreate(gfile,ios) ! write(0,*)'after nemsio_rcreate' if ( ios.ne.0) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif !------------------------------------------------------------ ! open and write meta data for WRITE !------------------------------------------------------------ elseif (equal_str_nocase(trim(gaction),"write")) then ! !-write 2D field using MPI I/O ! call mpi_file_open(mpi_comm,gfname,MPI_MODE_CREATE+MPI_MODE_WRONLY, & MPI_INFO_NULL,gfile%fh,ios) ! print *,'mype=',gfile%mype,'after mpi_file_open,ios=',ios if ( ios.ne.0) then if ( present(iret)) then return else call nemsio_stop endif endif ! !-write meta data for gfile, use non-mpi write for header ! 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,nmetavarr8=nmetavarr8,& nmetavarl=nmetavarl,nmetavarc=nmetavarc, & nmetaaryi=nmetaaryi,nmetaaryr=nmetaaryr,nmetaaryr8=nmetaaryr8,& nmetaaryl=nmetaaryl,nmetaaryc=nmetaaryc, & 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, & varr8name=varr8name,varr8val=varr8val, & aryiname=aryiname,aryilen=aryilen,aryival=aryival, & aryrname=aryrname,aryrlen=aryrlen,aryrval=aryrval, & aryr8name=aryr8name,aryr8len=aryr8len,aryr8val=aryr8val, & arylname=arylname,aryllen=aryllen,arylval=arylval, & arycname=arycname,aryclen=aryclen,arycval=arycval ) if ( ios.ne.0) 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.ne.0) then if (present(iret)) return call nemsio_stop endif endif ! iret=0 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine nemsio_open !------------------------------------------------------------------------------- subroutine nemsio_close(gfile,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! abstract: close gfile including closing the file, returning unit number, ! setting file meta data empty !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),optional,intent(out) :: iret integer(nemsio_intkind) :: ios !------------------------------------------------------------ ! close the file !------------------------------------------------------------ if ( present(iret) ) iret=-1 call mpi_file_close(gfile%fh,ios) if ( ios.ne.0) then if ( present(iret)) then return else call nemsio_stop endif endif !------------------------------------------------------------ ! empty gfile meta data !------------------------------------------------------------ call nemsio_axmeta(gfile,ios) if ( ios.ne.0) then if ( present(iret)) then iret=ios return else call nemsio_stop endif endif if ( present(iret)) iret=0 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine nemsio_close !------------------------------------------------------------------------------ subroutine nemsio_rcreate(gfile,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: read nemsio meta data !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret !local variables integer(nemsio_intkind) :: ios,nmeta,tlmeta4 integer(nemsio_intkind) :: iread integer (kind=mpi_offset_kind) ::idisp integer :: status(mpi_status_size) type(nemsio_meta1) :: meta1 type(nemsio_meta2) :: meta2 type(nemsio_meta3) :: meta3 integer(nemsio_intkind) :: i,nummeta character(nemsio_charkind8),allocatable :: char8var(:) !------------------------------------------------------------ ! open gfile for read header !------------------------------------------------------------ iret=-3 !------------------------------------------------------------ ! read first meta data record !------------------------------------------------------------ idisp=4 call mpi_file_read_at(gfile%fh,idisp,meta1,1,itypemeta1,status,ios) ! print *,'1 PE',gfile%mype,'ios=',ios,' gtype=',meta1%gtype, meta1%modelname, & ! meta1%gdatatype,meta1%version,meta1%nmeta,meta1%lmeta ! gfile%do_byteswap=.false. ! check byteswap if(meta1%lmeta/=120) then gfile%do_byteswap=.true. if(gfile%do_byteswap) call byteswap(meta1%version,nemsio_intkind,6) endif gfile%gtype=meta1%gtype gfile%gdatatype=meta1%gdatatype gfile%modelname=meta1%modelname gfile%version=meta1%version gfile%nmeta=meta1%nmeta gfile%lmeta=meta1%lmeta gfile%tlmeta=nemsio_lmeta1+8 if ( trim(gfile%gdatatype(1:3)).ne."bin" & .and. trim(gfile%gdatatype(1:4)).ne."grib" ) then gfile%gdatatype="grib" endif ! print *,'aft meta1,gtype=',trim(gfile%gtype),'version=',gfile%version, & ! 'nmeta=',gfile%nmeta,'gfile%lmeta=',gfile%lmeta,'gfile%gdatatype=', & ! gfile%gdatatype,'modelname=',gfile%modelname if ( gfile%gtype(1:6) .ne. 'NEMSIO' ) then iret=-9 return endif !------------------------------------------------------------ ! read second meta data record !------------------------------------------------------------ idisp=gfile%tlmeta+4 call mpi_file_read_at(gfile%fh,idisp,meta2,1,itypemeta2,status,ios) if(gfile%do_byteswap) then call byteswap(meta2%nrec,nemsio_intkind,25) call byteswap(meta2%rlon_min,nemsio_realkind,4) call byteswap(meta2%extrameta,nemsio_logickind,1) endif gfile%tlmeta=gfile%tlmeta+nemsio_intkind*25+nemsio_realkind*4+nemsio_logickind+8 ! gfile%nrec=meta2%nrec gfile%idate(1:7)=meta2%idate(1:7) gfile%nfday=meta2%nfday gfile%nfhour=meta2%nfhour gfile%nfminute=meta2%nfminute gfile%nfsecondn=meta2%nfsecondn gfile%nfsecondd=meta2%nfsecondd gfile%dimx=meta2%dimx gfile%dimy=meta2%dimy gfile%dimz=meta2%dimz gfile%nframe=meta2%nframe gfile%nsoil=meta2%nsoil gfile%ntrac=meta2%ntrac gfile%jcap=meta2%jcap gfile%ncldt=meta2%ncldt gfile%idvc=meta2%idvc gfile%idsl=meta2%idsl gfile%idvm=meta2%idvm gfile%idrt=meta2%idrt gfile%rlon_min=meta2%rlon_min gfile%rlon_max=meta2%rlon_max gfile%rlat_min=meta2%rlat_min gfile%rlat_max=meta2%rlat_max gfile%extrameta=meta2%extrameta gfile%fieldsize=(gfile%dimx+2*gfile%nframe)*(gfile%dimy+2*gfile%nframe) ! print *,'meta2,nrec=',gfile%nrec,gfile%idate(1:7),gfile%nfday, & ! gfile%nfhour,gfile%nfminute,gfile%nfsecondn,gfile%nfsecondd, & ! gfile%dimx,gfile%dimy,gfile%dimz,gfile%nframe,gfile%nsoil, & ! gfile%ntrac,gfile%jcap,gfile%ncldt,gfile%idvc,gfile%idsl, & ! gfile%idvm,gfile%idrt,gfile%rlon_min,gfile%rlon_max, & ! gfile%rlat_min,gfile%rlat_max,gfile%extrameta nummeta=gfile%nmeta !------------------------------------------------------------ ! set up gfile required meata arrays !------------------------------------------------------------ call nemsio_almeta(gfile,ios) if ( ios .ne. 0 ) then iret=ios return endif !------------------------------------------------------------ ! read gfile meta data array (meta rec 3:13) !------------------------------------------------------------ !meta3:recname if(nummeta>2) then idisp=gfile%tlmeta+4 iread=len(gfile%recname)*size(gfile%recname) call mpi_file_read_at(gfile%fh,idisp,gfile%recname,iread,MPI_CHARACTER,status,ios) nmeta=nmeta-1 gfile%tlmeta=gfile%tlmeta+iread+8 endif !meta4:reclevtyp if(nummeta>3) then idisp=gfile%tlmeta+4 call mpi_file_read_at(gfile%fh,idisp,gfile%reclevtyp,iread,MPI_CHARACTER,status,ios) nmeta=nmeta-1 gfile%tlmeta=gfile%tlmeta+iread+8 endif !meta5:reclev if(nummeta>4) then idisp=gfile%tlmeta+4 iread=size(gfile%reclev) call mpi_file_read_at(gfile%fh,idisp,gfile%reclev,iread,MPI_INTEGER,status,ios) if(gfile%do_byteswap) call byteswap(gfile%reclev,nemsio_intkind,size(gfile%reclev)) nmeta=nmeta-1 gfile%tlmeta=gfile%tlmeta+kind(gfile%reclev)*iread+8 endif !meta6:vcoord if(nummeta>5) then idisp=gfile%tlmeta+4 iread=size(gfile%vcoord) call mpi_file_read_at(gfile%fh,idisp,gfile%vcoord,iread,MPI_REAL,status,ios) if(gfile%do_byteswap) call byteswap(gfile%vcoord,nemsio_realkind,size(gfile%vcoord)) nmeta=nmeta-1 gfile%tlmeta=gfile%tlmeta+kind(gfile%vcoord)*iread+8 endif !meta7:lat if(nummeta>6) then idisp=gfile%tlmeta+4 iread=size(gfile%lat) call mpi_file_read_at(gfile%fh,idisp,gfile%lat,iread,MPI_REAL,status,ios) if(gfile%do_byteswap) call byteswap(gfile%lat,nemsio_realkind,size(gfile%lat)) nmeta=nmeta-1 gfile%tlmeta=gfile%tlmeta+kind(gfile%lat)*iread+8 endif !meta8:lon if(nummeta>7) then idisp=gfile%tlmeta+4 call mpi_file_read_at(gfile%fh,idisp,gfile%lon,iread,MPI_REAL,status,ios) if(gfile%do_byteswap) call byteswap(gfile%lon,nemsio_realkind,size(gfile%lon)) nmeta=nmeta-1 gfile%tlmeta=gfile%tlmeta+kind(gfile%lon)*iread+8 endif !meta9:dx if(nummeta>8) then idisp=gfile%tlmeta+4 call mpi_file_read_at(gfile%fh,idisp,gfile%dx,iread,MPI_REAL,status,ios) if(gfile%do_byteswap) call byteswap(gfile%dx,nemsio_realkind,size(gfile%dx)) nmeta=nmeta-1 gfile%tlmeta=gfile%tlmeta+kind(gfile%dx)*iread+8 endif !meta10:dy if(nummeta>9) then idisp=gfile%tlmeta+4 call mpi_file_read_at(gfile%fh,idisp,gfile%dy,iread,MPI_REAL,status,ios) if(gfile%do_byteswap) call byteswap(gfile%dy,nemsio_realkind,size(gfile%dy)) nmeta=nmeta-1 gfile%tlmeta=gfile%tlmeta+kind(gfile%dy)*iread+8 endif !meta11:cpi if(nummeta>10) then idisp=gfile%tlmeta+4 iread=size(gfile%cpi) call mpi_file_read_at(gfile%fh,idisp,gfile%cpi,iread,MPI_REAL,status,ios) if(gfile%do_byteswap) call byteswap(gfile%cpi,nemsio_realkind,size(gfile%cpi)) nmeta=nmeta-1 gfile%tlmeta=gfile%tlmeta+kind(gfile%cpi)*iread+8 endif !Ri if(nummeta>11) then idisp=gfile%tlmeta+4 call mpi_file_read_at(gfile%fh,idisp,gfile%ri,iread,MPI_REAL,status,ios) if(gfile%do_byteswap) call byteswap(gfile%ri,nemsio_realkind,size(gfile%ri)) nmeta=nmeta-1 gfile%tlmeta=gfile%tlmeta+kind(gfile%ri)*iread+8 endif ! extrameta_if: if(gfile%extrameta) then !------------------------------------------------------------ ! read out extra meta data !------------------------------------------------------------ idisp=gfile%tlmeta call mpi_file_read_at(gfile%fh,idisp,iread,1,MPI_INTEGER,status,ios) if(gfile%do_byteswap) call byteswap(iread,nemsio_intkind,1) idisp=gfile%tlmeta+4 if(iread/4==10) then call mpi_file_read_at(gfile%fh,idisp,meta3,10,MPI_INTEGER,status,ios) if(gfile%do_byteswap) call byteswap(meta3,nemsio_intkind,10) gfile%nmetavarr8=meta3%nmetavarr8 gfile%nmetaaryr8=meta3%nmetaaryr8 gfile%tlmeta=gfile%tlmeta+nemsio_lmeta3+8 elseif(iread/4==8) then call mpi_file_read_at(gfile%fh,idisp,meta3,8,MPI_INTEGER,status,ios) if(gfile%do_byteswap) call byteswap(meta3,nemsio_intkind,8) gfile%tlmeta=gfile%tlmeta+nemsio_lmeta3 endif gfile%nmetavari=meta3%nmetavari gfile%nmetavarr=meta3%nmetavarr gfile%nmetavarl=meta3%nmetavarl gfile%nmetavarc=meta3%nmetavarc gfile%nmetaaryi=meta3%nmetaaryi gfile%nmetaaryr=meta3%nmetaaryr gfile%nmetaaryl=meta3%nmetaaryl gfile%nmetaaryc=meta3%nmetaaryc ! ! print *,'after meta3,nmetavari=',gfile%nmetavari,'nvarr=',gfile%nmetavarr, & ! 'varl=',gfile%nmetavarl,'varc=',gfile%nmetavarc, gfile%nmetavarr8,'naryi=',& ! gfile%nmetaaryi,gfile%nmetaaryr,gfile%nmetaaryl,gfile%nmetaaryc,gfile%nmetaaryr8,& ! 'iread=',iread call nemsio_alextrameta(gfile,ios) if ( ios .ne. 0 ) then iret=ios return endif !meta var integer if (gfile%nmetavari.gt.0) then idisp=gfile%tlmeta+4 iread=len(gfile%variname)*gfile%nmetavari call mpi_file_read_at(gfile%fh,idisp,gfile%variname,iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 ! idisp=gfile%tlmeta+4 iread=gfile%nmetavari call mpi_file_read_at(gfile%fh,idisp,gfile%varival,iread,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%varival,nemsio_intkind,iread) gfile%tlmetavarival=gfile%tlmeta gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8 endif ! !meta var real if (gfile%nmetavarr.gt.0) then idisp=gfile%tlmeta+4 iread=len(gfile%varrname)*gfile%nmetavarr call mpi_file_read_at(gfile%fh,idisp,gfile%varrname,iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 ! idisp=gfile%tlmeta+4 iread=gfile%nmetavarr call mpi_file_read_at(gfile%fh,idisp,gfile%varrval,iread,MPI_REAL,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%varrval,nemsio_realkind,iread) gfile%tlmeta=gfile%tlmeta+iread*nemsio_realkind+8 endif ! !meta var logical if (gfile%nmetavarl.gt.0) then idisp=gfile%tlmeta+4 iread=len(gfile%varlname)*gfile%nmetavarl call mpi_file_read_at(gfile%fh,idisp,gfile%varlname,iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 ! idisp=gfile%tlmeta+4 iread=gfile%nmetavarl call mpi_file_read_at(gfile%fh,idisp,gfile%varlval,iread,MPI_LOGICAL,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%varlval,nemsio_logickind,iread) gfile%tlmeta=gfile%tlmeta+iread*nemsio_logickind+8 endif ! !meta var character if (gfile%nmetavarc.gt.0) then idisp=gfile%tlmeta+4 iread=len(gfile%varcname)*gfile%nmetavarc call mpi_file_read_at(gfile%fh,idisp,gfile%varcname,iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 ! idisp=gfile%tlmeta+4 iread=len(gfile%varcname)*gfile%nmetavarc call mpi_file_read_at(gfile%fh,idisp,gfile%varcval,iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 endif !meta var real 8 if (gfile%nmetavarr8.gt.0) then idisp=gfile%tlmeta+4 iread=len(gfile%varr8name)*gfile%nmetavarr8 call mpi_file_read_at(gfile%fh,idisp,gfile%varr8name,iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 ! idisp=gfile%tlmeta+4 iread=gfile%nmetavarr8 call mpi_file_read_at(gfile%fh,idisp,gfile%varr8val,iread,MPI_REAL8,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%varr8val,nemsio_dblekind,iread) gfile%tlmeta=gfile%tlmeta+iread*nemsio_dblekind+8 endif ! !meta arr integer if (gfile%nmetaaryi.gt.0) then idisp=gfile%tlmeta+4 iread=len(gfile%aryiname)*gfile%nmetaaryi call mpi_file_read_at(gfile%fh,idisp,gfile%aryiname,iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 ! idisp=gfile%tlmeta+4 iread=gfile%nmetaaryi call mpi_file_read_at(gfile%fh,idisp,gfile%aryilen,iread,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryilen,nemsio_intkind,iread) gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8 ! allocate(gfile%aryival(maxval(gfile%aryilen),gfile%nmetaaryi)) do i=1,gfile%nmetaaryi idisp=gfile%tlmeta+4 iread=gfile%aryilen(i) call mpi_file_read_at(gfile%fh,idisp,gfile%aryival(1:iread,i),iread,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryival(:,i),nemsio_intkind,iread) gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8 enddo endif !meta arr real if (gfile%nmetaaryr.gt.0) then idisp=gfile%tlmeta+4 iread=len(gfile%aryrname)*gfile%nmetaaryr call mpi_file_read_at(gfile%fh,idisp,gfile%aryrname,iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 ! idisp=gfile%tlmeta+4 iread=gfile%nmetaaryr call mpi_file_read_at(gfile%fh,idisp,gfile%aryrlen,iread,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryrlen,nemsio_intkind,iread) gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8 ! allocate(gfile%aryrval(maxval(gfile%aryrlen),gfile%nmetaaryr)) do i=1,gfile%nmetaaryr idisp=gfile%tlmeta+4 iread=gfile%aryrlen(i) call mpi_file_read_at(gfile%fh,idisp,gfile%aryrval(1:iread,i),iread,MPI_REAL,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryrval(1:iread,i),nemsio_realkind,iread) gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8 enddo endif !meta arr logical if (gfile%nmetaaryl.gt.0) then idisp=gfile%tlmeta+4 iread=len(gfile%arylname)*gfile%nmetaaryl call mpi_file_read_at(gfile%fh,idisp,gfile%arylname,iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 ! idisp=gfile%tlmeta+4 iread=gfile%nmetaaryl call mpi_file_read_at(gfile%fh,idisp,gfile%aryllen,iread,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryllen,nemsio_intkind,iread) gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8 ! allocate(gfile%arylval(maxval(gfile%aryllen),gfile%nmetaaryl)) do i=1,gfile%nmetaaryl idisp=gfile%tlmeta+4 iread=gfile%aryllen(i) call mpi_file_read_at(gfile%fh,idisp,gfile%arylval(1:iread,i),iread,MPI_LOGICAL,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%arylval(1:iread,i),nemsio_logickind,iread) gfile%tlmeta=gfile%tlmeta+iread*nemsio_logickind+8 enddo endif !meta arr char if (gfile%nmetaaryc.gt.0) then idisp=gfile%tlmeta+4 iread=len(gfile%arycname)*gfile%nmetaaryc call mpi_file_read_at(gfile%fh,idisp,gfile%arycname,iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 ! idisp=gfile%tlmeta+4 iread=gfile%nmetaaryc call mpi_file_read_at(gfile%fh,idisp,gfile%aryclen,iread,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryclen,nemsio_intkind,gfile%nmetaaryc) gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8 ! allocate(gfile%arycval(maxval(gfile%aryclen),gfile%nmetaaryc)) do i=1,gfile%nmetaaryc idisp=gfile%tlmeta+4 iread=gfile%aryclen(i)*len(gfile%arycval) call mpi_file_read_at(gfile%fh,idisp,gfile%arycval(1:iread,i),iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 enddo endif !meta arr real8 if (gfile%nmetaaryr8.gt.0) then idisp=gfile%tlmeta+4 iread=len(gfile%aryr8name)*gfile%nmetaaryr8 call mpi_file_read_at(gfile%fh,idisp,gfile%aryr8name,iread,MPI_CHARACTER,status,ios) gfile%tlmeta=gfile%tlmeta+iread+8 ! idisp=gfile%tlmeta+4 iread=gfile%nmetaaryr8 call mpi_file_read_at(gfile%fh,idisp,gfile%aryr8len,iread,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryr8len,nemsio_intkind,iread) gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8 ! allocate(gfile%aryr8val(maxval(gfile%aryr8len),gfile%nmetaaryr8)) do i=1,gfile%nmetaaryr8 idisp=gfile%tlmeta+4 iread=gfile%aryr8len(i) call mpi_file_read_at(gfile%fh,idisp,gfile%aryr8val(1:iread,i),iread,MPI_REAL,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryr8val(1:iread,i),nemsio_dblekind,iread) gfile%tlmeta=gfile%tlmeta+iread*nemsio_dblekind+8 enddo endif ! !end if extrameta endif extrameta_if ! call MPI_Barrier(gfile%mpi_comm, ios) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - iret=0 end subroutine nemsio_rcreate !------------------------------------------------------------------------------ subroutine nemsio_wcreate(gfile,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,nmetavarc,nmetavarr8, & nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc,nmetaaryr8, & recname,reclevtyp,reclev,vcoord,lat,lon,dx,dy,cpi,ri, & variname,varival,varrname,varrval,varlname,varlval,varcname,varcval, & varr8name,varr8val, & aryiname,aryilen,aryival,aryrname,aryrlen,aryrval, & arylname,aryllen,arylval,arycname,aryclen,arycval, & aryr8name,aryr8len,aryr8val ) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: write nemsio meta data !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret !optional variables character*(*),optional,intent(in) :: gdatatype,modelname integer(nemsio_intkind),optional,intent(in) :: version,nmeta,lmeta,nrec integer(nemsio_intkind),optional,intent(in) :: idate(7),nfday,nfhour, & nfminute,nfsecondn,nfsecondd integer(nemsio_logickind),optional,intent(in):: dimx,dimy,dimz,nframe, & nsoil,ntrac integer(nemsio_logickind),optional,intent(in):: jcap,ncldt,idvc,idsl, & idvm,idrt real(nemsio_realkind),optional,intent(in) :: rlat_min,rlat_max, & rlon_min,rlon_max logical(nemsio_logickind),optional,intent(in):: extrameta integer(nemsio_intkind),optional,intent(in) :: nmetavari,nmetavarr, & nmetavarl,nmetavarc,nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc, & nmetavarr8,nmetaaryr8 ! character*(*),optional,intent(in) :: recname(:),reclevtyp(:) integer(nemsio_intkind),optional,intent(in) :: reclev(:) real(nemsio_realkind),optional,intent(in) :: vcoord(:,:,:) real(nemsio_realkind),optional,intent(in) :: lat(:),lon(:) real(nemsio_realkind),optional,intent(in) :: dx(:),dy(:) real(nemsio_realkind),optional,intent(in) :: Cpi(:),Ri(:) ! character*(*),optional,intent(in) :: variname(:),varrname(:),& varlname(:),varcname(:),varr8name(:),aryiname(:),aryrname(:), & arylname(:),arycname(:),aryr8name(:) integer(nemsio_intkind),optional,intent(in) :: aryilen(:),aryrlen(:), & aryllen(:),aryclen(:),aryr8len(:) integer(nemsio_intkind),optional,intent(in) :: varival(:),aryival(:,:) real(nemsio_realkind),optional,intent(in) :: varrval(:),aryrval(:,:) real(nemsio_dblekind),optional,intent(in) :: varr8val(:),aryr8val(:,:) logical(nemsio_logickind),optional,intent(in):: varlval(:),arylval(:,:) character(*),optional,intent(in) :: varcval(:),arycval(:,:) ! !--- local variables ! real(nemsio_realkind) :: radi integer(nemsio_intkind) :: iwrite,nwrite type(nemsio_meta1) :: meta1 type(nemsio_meta2) :: meta2 type(nemsio_meta3) :: meta3 integer(nemsio_intkind) :: i,n,ios,nummeta integer :: status(MPI_STATUS_SIZE) integer (kind=mpi_offset_kind) :: idisp logical :: linit !------------------------------------------------------------ ! set gfile meta data to operational model (default) if it's empty !------------------------------------------------------------ iret=-3 gfile%gtype="NEMSIO" gfile%do_byteswap=.false. if(present(gdatatype)) then if ( trim(gdatatype).ne.'grib'.and.gdatatype(1:3).ne.'bin'.and. & trim(gdatatype).ne.'') return gfile%gdatatype=gdatatype if(trim(gdatatype)=='') gfile%gdatatype='grib' if(index(gfile%gdatatype,'_be')>0) then gfile%file_endian='big_endian' elseif(index(gfile%gdatatype,'_le')>0) then gfile%file_endian='little_endian' else gfile%file_endian=machine_endian endif if(trim(machine_endian)/=trim(gfile%file_endian)) gfile%do_byteswap=.true. elseif(trim(gfile%gdatatype).eq.'') then gfile%gdatatype='grib' endif ! print *,'in wcreate,mype=',gfile%mype,'file_endian=',gfile%file_endian, & ! 'machine_endian=',machine_endian if(present(modelname)) then gfile%modelname=modelname else gfile%modelname="GFS" endif ! print *,'NEMSIO file,datatype,model is ',gfile%gtype, & ! gfile%gdatatype,gfile%modelname,idate(1:7),'machine_endian=', & ! machine_endian,'gfile%file_endian=',gfile%file_endian,'gfile%do_byteswap=',gfile%do_byteswap if(present(version)) gfile%version=version if(present(dimx)) gfile%dimx=dimx if(present(dimy)) gfile%dimy=dimy if(present(dimz)) gfile%dimz=dimz if(present(nrec)) gfile%nrec=nrec if(present(nmeta)) gfile%nmeta=nmeta if(gfile%nmeta==nemsio_intfill) gfile%nmeta=12 if(present(lmeta)) gfile%lmeta=lmeta if(gfile%lmeta==nemsio_intfill) & gfile%lmeta=25*nemsio_intkind+4*nemsio_realkind+nemsio_logickind if(present(nsoil)) gfile%nsoil=nsoil if(gfile%nsoil.eq.nemsio_intfill) gfile%nsoil=4 if(present(nframe)) gfile%nframe=nframe if(gfile%nframe.eq.nemsio_intfill) gfile%nframe=0 if(trim(gfile%modelname)=='GFS')gfile%nframe=0 if(present(idate)) gfile%idate=idate if ( gfile%idate(1) .lt. 50) then gfile%idate(1)=2000+gfile%idate(1) else if (gfile%idate(1) .lt. 100) then gfile%idate(1)=1999+gfile%idate(1) endif if ( gfile%idate(1).eq.nemsio_intfill) then print *,'idate=',gfile%idate,' WRONG: please provide idate(1:7)(yyyy/mm/dd/hh/min/secn/secd)!!!' call nemsio_stop() endif ! if ( gfile%gtype(1:6).eq."NEMSIO" ) then call nemsio_gfinit(gfile,ios,recname=recname,reclevtyp=reclevtyp,reclev=reclev) if (ios .ne.0 ) then iret=ios return endif endif ! !------------------------------------------------------------ ! set up basic gfile meta data variables from outsides to ! define meta data array !------------------------------------------------------------ if(present(nfday)) gfile%nfday=nfday if(present(nfhour)) gfile%nfhour=nfhour if(present(nfminute)) gfile%nfminute=nfminute if(present(nfsecondn)) gfile%nfsecondn=nfsecondn if(present(nfsecondd)) gfile%nfsecondd=nfsecondd if(present(ntrac)) gfile%ntrac=ntrac if(gfile%ntrac.eq.nemsio_intfill) gfile%ntrac=0 if(present(ncldt)) gfile%ncldt=ncldt if(present(jcap)) gfile%jcap=jcap if(present(idvc)) gfile%idvc=idvc if(present(idsl)) gfile%idsl=idsl if(present(idvm)) gfile%idvm=idvm if(present(idrt)) gfile%idrt=idrt if(present(rlon_min)) gfile%rlon_min=rlon_min if(present(rlon_max)) gfile%rlon_max=rlon_max if(present(rlat_min)) gfile%rlat_min=rlat_min if(present(rlat_max)) gfile%rlat_max=rlat_max if(present(extrameta)) gfile%extrameta=extrameta if(gfile%fieldsize.eq.nemsio_intfill) & gfile%fieldsize=(gfile%dimx+2*gfile%nframe)*(gfile%dimy+2*gfile%nframe) if(gfile%mype.eq.gfile%lead_task) then if(gfile%gdatatype(1:4).eq.'bin4') then call mpi_send(gfile%fieldsize*nemsio_realkind,1,MPI_integer,0,99,gfile%mpi_comm,ios) call mpi_recv(gfile%fieldsize_real4,1,MPI_real4,0,99,gfile%mpi_comm,status,ios) elseif(gfile%gdatatype(1:4).eq.'bin8') then call mpi_send(gfile%fieldsize*nemsio_dblekind,1,MPI_integer,0,99,gfile%mpi_comm,ios) call mpi_recv(gfile%fieldsize_real8,1,MPI_real8,0,99,gfile%mpi_comm,status,ios) endif endif ! !--------------------------------------------------------------------- !*** for lead write task !--------------------------------------------------------------------- ! if(gfile%mype.eq.gfile%lead_task) then ! if( gfile%extrameta )then if(present(nmetavari).and.present(variname).and.present(varival)) then if(nmetavari.gt.0 .and.size(variname).eq.nmetavari .and. & size(varival).eq.nmetavari) then gfile%nmetavari=nmetavari if(allocated(gfile%variname)) deallocate(gfile%variname) if(allocated(gfile%varival)) deallocate(gfile%varival) allocate(gfile%variname(nmetavari),gfile%varival(nmetavari)) gfile%variname=variname gfile%varival=varival endif endif if(present(nmetavarr).and.present(varrname).and.present(varrval)) then if( nmetavarr.gt.0.and.size(varrname).eq.nmetavarr .and. & size(varrval).eq.nmetavarr) then gfile%nmetavarr=nmetavarr if(allocated(gfile%varrname)) deallocate(gfile%varrname) if(allocated(gfile%varrval)) deallocate(gfile%varrval) allocate(gfile%varrname(nmetavarr),gfile%varrval(nmetavarr)) gfile%varrname=varrname gfile%varrval=varrval endif endif if(present(nmetavarl).and.present(varlname).and.present(varlval)) then if( nmetavarl.gt.0.and.size(varlname).eq.nmetavarl .and. & size(varlval).eq.nmetavarl) then gfile%nmetavarl=nmetavarl if(allocated(gfile%varlname)) deallocate(gfile%varlname) if(allocated(gfile%varlval)) deallocate(gfile%varlval) allocate(gfile%varlname(nmetavarl),gfile%varlval(nmetavarl)) gfile%varlname=varlname gfile%varlval=varlval endif endif if(present(nmetavarc).and.present(varcname).and.present(varcval)) then if( nmetavarc.gt.0.and.size(varcname).eq.nmetavarc .and. & size(varcval).eq.nmetavarc) then gfile%nmetavarc=nmetavarc if(allocated(gfile%varcname)) deallocate(gfile%varcname) if(allocated(gfile%varcval)) deallocate(gfile%varcval) allocate(gfile%varcname(nmetavarc),gfile%varcval(nmetavarc)) gfile%varcname=varcname gfile%varcval=varcval endif endif if(present(nmetavarr8).and.present(varr8name).and.present(varr8val)) then if( nmetavarr8.gt.0.and.size(varr8name).eq.nmetavarr8 .and. & size(varr8val).eq.nmetavarr8) then gfile%nmetavarr8=nmetavarr8 if(allocated(gfile%varr8name)) deallocate(gfile%varr8name) if(allocated(gfile%varr8val)) deallocate(gfile%varr8val) allocate(gfile%varr8name(nmetavarr8),gfile%varr8val(nmetavarr8)) gfile%varr8name=varr8name gfile%varr8val=varr8val endif endif if(present(nmetaaryi).and.present(aryiname).and.present(aryilen)) then if( nmetaaryi.gt.0.and.size(aryiname).eq.nmetaaryi .and. & size(aryilen).eq.nmetaaryi) then gfile%nmetaaryi=nmetaaryi if(allocated(gfile%aryiname)) deallocate(gfile%aryiname) if(allocated(gfile%aryilen)) deallocate(gfile%aryilen) allocate(gfile%aryiname(nmetaaryi),gfile%aryilen(nmetaaryi)) gfile%aryiname=aryiname gfile%aryilen=aryilen if(present(aryival)) then if(size(aryival).eq.nmetaaryi*maxval(gfile%aryilen) ) then if(allocated(gfile%aryival)) deallocate(gfile%aryival) allocate(gfile%aryival(maxval(gfile%aryilen),nmetaaryi)) gfile%aryival=aryival endif endif endif endif if(present(nmetaaryr).and.present(aryrname).and.present(aryrlen)) then if( nmetaaryr.gt.0.and.size(aryrname).eq.nmetaaryr .and. & size(aryrlen).eq.nmetaaryr) then gfile%nmetaaryr=nmetaaryr if(allocated(gfile%aryrname)) deallocate(gfile%aryrname) if(allocated(gfile%aryrlen)) deallocate(gfile%aryrlen) allocate(gfile%aryrname(nmetaaryr),gfile%aryrlen(nmetaaryr)) gfile%aryrname=aryrname gfile%aryrlen=aryrlen if(present(aryrval) ) then if(size(aryrval).eq.nmetaaryr*maxval(gfile%aryrlen)) then if(allocated(gfile%aryrval)) deallocate(gfile%aryrval) allocate(gfile%aryrval(maxval(gfile%aryrlen),nmetaaryr)) gfile%aryrval=aryrval endif endif endif endif if(present(nmetaaryl).and.present(arylname).and.present(aryllen)) then if( nmetaaryl.gt.0 .and.size(arylname).eq.nmetaaryl .and. & size(aryllen).eq.nmetaaryl) then gfile%nmetaaryl=nmetaaryl if(allocated(gfile%arylname)) deallocate(gfile%arylname) if(allocated(gfile%aryllen)) deallocate(gfile%aryllen) allocate(gfile%arylname(nmetaaryl),gfile%aryllen(nmetaaryl)) gfile%arylname=arylname gfile%aryllen=aryllen if(present(arylval)) then if(size(arylval).eq.nmetaaryl*maxval(gfile%aryllen)) then if(allocated(gfile%arylval)) deallocate(gfile%arylval) allocate(gfile%arylval(maxval(gfile%aryllen),nmetaaryl)) gfile%arylval=arylval endif endif endif endif if(present(nmetaaryc).and.present(arycname).and.present(aryclen)) then if( nmetaaryc.gt.0 .and.size(arycname).eq.nmetaaryc .and. & size(aryclen).eq.nmetaaryc) then gfile%nmetaaryc=nmetaaryc if(allocated(gfile%arycname)) deallocate(gfile%arycname) if(allocated(gfile%aryclen)) deallocate(gfile%aryclen) allocate(gfile%arycname(nmetaaryc),gfile%aryclen(nmetaaryc)) gfile%arycname=arycname gfile%aryclen=aryclen if(present(arycval)) then if(size(arycval).eq.nmetaaryc*maxval(gfile%aryclen)) then if(allocated(gfile%arycval)) deallocate(gfile%arycval) allocate(gfile%arycval(maxval(gfile%aryclen),nmetaaryc)) gfile%arycval=arycval endif endif endif endif if(present(nmetaaryr8).and.present(aryr8name).and.present(aryr8len)) then if( nmetaaryr8.gt.0.and.size(aryr8name).eq.nmetaaryr8 .and. & size(aryr8len).eq.nmetaaryr8) then gfile%nmetaaryr8=nmetaaryr8 if(allocated(gfile%aryr8name)) deallocate(gfile%aryr8name) if(allocated(gfile%aryr8len)) deallocate(gfile%aryr8len) allocate(gfile%aryr8name(nmetaaryr8),gfile%aryr8len(nmetaaryr8)) gfile%aryr8name=aryr8name gfile%aryr8len=aryr8len if(present(aryr8val) ) then if(size(aryr8val).eq.nmetaaryr8*maxval(gfile%aryr8len)) then if(allocated(gfile%aryr8val)) deallocate(gfile%aryr8val) allocate(gfile%aryr8val(maxval(gfile%aryr8len),nmetaaryr8)) gfile%aryr8val=aryr8val endif endif endif endif if (gfile%nmetavari+gfile%nmetavarr+gfile%nmetavarl+gfile%nmetavarc+ & gfile%nmetaaryi+gfile%nmetaaryr+gfile%nmetaaryl+gfile%nmetaaryc+ & gfile%nmetavarr8+gfile%nmetaaryr8 .lt.10*nemsio_intfill )then print *,'WRONG: gfile%extrameta is not compatiable with input extra meta!' return endif endif ! !------------------------------------------------------------ ! check gfile meta data array size !------------------------------------------------------------ call nemsio_chkgfary(gfile,ios) if (ios.ne. 0) then iret=ios return endif !------------------------------------------------------------ ! continue to set gfile meta data variables tnd arrays !------------------------------------------------------------ !set gfile data type to bin/grb, default set to grb !recname nummeta=2 if(present(recname) ) then if (gfile%nrec.eq.size(recname)) then gfile%recname=recname else print *,'WRONG: the size of recname is not equal to the total number of the fields in the file!' return endif nummeta=nummeta+1 endif !reclevtyp if(present(reclevtyp)) then if (gfile%nrec.eq.size(reclevtyp)) then gfile%reclevtyp=reclevtyp else print *,'WRONG: the size of reclevtyp is not equal to the total number of the fields in the file!' return endif nummeta=nummeta+1 endif !reclev if(present(reclev) ) then if (gfile%nrec.eq.size(reclev)) then gfile%reclev=reclev else print *,'WRONG: the size of reclev is not equal to the total number of the fields in the file!' return endif nummeta=nummeta+1 endif !vcoord vcoord(levs+1 if(present(vcoord) ) then if ((gfile%dimz+1)*3*2.eq.size(vcoord)) then gfile%vcoord=vcoord else print *,'WRONG: the size of vcoord is not (lm+1,3,2) !' return endif nummeta=nummeta+1 endif !lat if(present(lat) ) then if (gfile%fieldsize.eq.size(lat)) then if(.not.(all(lat==0.))) gfile%lat=lat else print *,'WRONG: the input size(lat) ',size(lat),' is not equal to: ',gfile%fieldsize return endif nummeta=nummeta+1 endif if(allocated(gfile%lat)) then gfile%rlat_max=maxval(gfile%lat) gfile%rlat_min=minval(gfile%lat) endif !lon if(present(lon) ) then if (gfile%fieldsize.eq.size(lon)) then if(.not.(all(lon==0.)) ) gfile%lon=lon else print *,'WRONG: the input size(lon) ',size(lon),' is not equal to: ',gfile%fieldsize return endif nummeta=nummeta+1 endif if(allocated(gfile%lon)) then gfile%rlon_max=maxval(gfile%lon) gfile%rlon_min=minval(gfile%lon) endif !dx if(present(dx) ) then if (gfile%fieldsize.eq.size(dx)) then if(.not.(all(dx==0.)) ) gfile%dx=dx else print *,'WRONG: the input size(dx) ',size(dx),' is not equal to: ',gfile%fieldsize return endif nummeta=nummeta+1 endif !dy if(present(dy) ) then if (gfile%fieldsize.eq.size(dy)) then if(.not.(all(dy==0.)) ) gfile%dy=dy else print *,'WRONG: the input size(dy) ',size(dy),' is not equal to: ',gfile%fieldsize return endif nummeta=nummeta+1 endif !Cpi if( present(Cpi) ) then if (gfile%ntrac+1.eq.size(gfile%Cpi)) then if(.not.(all(cpi==0.))) gfile%Cpi = Cpi else print *,'WRONG: the input size(cpi) ',size(cpi),' is not equal to: ',gfile%ntrac+1 return endif nummeta=nummeta+1 endif !Ri if( present(Ri) ) then if (gfile%ntrac+1.eq.size(gfile%Ri)) then if(.not.(all(ri==0.))) gfile%Ri = Ri else print *,'WRONG: the input size(ri) ',size(ri),' is not equal to: ',gfile%ntrac+1 return endif nummeta=nummeta+1 endif if(gfile%nmeta==nemsio_intfill) gfile%nmeta=nummeta !------------------------------------------------------------ ! write out the header by lead_task !------------------------------------------------------------ !------------------------------------------------------------ ! write out first meta data record !------------------------------------------------------------ meta1%gtype=gfile%gtype meta1%gdatatype=gfile%gdatatype meta1%modelname=gfile%modelname meta1%version=gfile%version meta1%nmeta=gfile%nmeta meta1%lmeta=gfile%lmeta meta1%reserve=0 idisp=0 iwrite=nemsio_lmeta1 if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) idisp=4 if(gfile%do_byteswap) call byteswap(meta1%version,nemsio_intkind,6) call mpi_file_write_at(gfile%fh,idisp,meta1,1,itypemeta1,status,ios) if(gfile%do_byteswap) call byteswap(meta1%version,nemsio_intkind,6) idisp=4+nemsio_lmeta1 call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) gfile%tlmeta=nemsio_lmeta1+8 !------------------------------------------------------------ ! write out second meta data record !------------------------------------------------------------ meta2%nrec=gfile%nrec meta2%idate(1:7)=gfile%idate(1:7) meta2%nfday=gfile%nfday meta2%nfhour=gfile%nfhour meta2%nfminute=gfile%nfminute meta2%nfsecondn=gfile%nfsecondn meta2%nfsecondd=gfile%nfsecondd meta2%dimx=gfile%dimx meta2%dimy=gfile%dimy meta2%dimz=gfile%dimz meta2%nframe=gfile%nframe meta2%nsoil=gfile%nsoil meta2%ntrac=gfile%ntrac meta2%jcap=gfile%jcap meta2%ncldt=gfile%ncldt meta2%idvc=gfile%idvc meta2%idsl=gfile%idsl meta2%idvm=gfile%idvm meta2%idrt=gfile%idrt meta2%rlon_min=gfile%rlon_min meta2%rlon_max=gfile%rlon_max meta2%rlat_min=gfile%rlat_min meta2%rlat_max=gfile%rlat_max meta2%extrameta=gfile%extrameta idisp=gfile%tlmeta iwrite=gfile%lmeta if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) if(gfile%do_byteswap) then call byteswap(meta2%nrec,nemsio_intkind,25) call byteswap(meta2%rlon_min,nemsio_realkind,4) call byteswap(meta2%extrameta,nemsio_logickind,1) endif idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,meta2,1,itypemeta2,status,ios) if(gfile%do_byteswap) then call byteswap(meta2%nrec,nemsio_intkind,25) call byteswap(meta2%rlon_min,nemsio_realkind,4) call byteswap(meta2%extrameta,nemsio_logickind,1) endif idisp=idisp+gfile%lmeta call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+gfile%lmeta+8 ! print *,'tlmet2 =',gfile%tlmeta,'nwrite=',nwrite,'meta2=', & ! meta2%dimx,meta2%dimy,meta2%dimz,meta2%nframe,meta2%nsoil, & ! meta2%ntrac,meta2%jcap,meta2%ncldt,meta2%idvc,meta2%idsl, & ! meta2%idvm,meta2%idrt,meta2%rlon_min,meta2%rlon_max, & ! meta2%rlat_min,meta2%rlat_max,meta2%extrameta nummeta=gfile%nmeta !------------------------------------------------------------ ! write out 3rd-13th meta data record (arrays) !------------------------------------------------------------ !recname if( nummeta>2) then idisp=gfile%tlmeta iwrite=nemsio_charkind*size(gfile%recname) if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%recname,iwrite,MPI_CHARACTER,status,ios) if(ios<0) return idisp=idisp+nemsio_charkind*size(gfile%recname) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+nemsio_charkind*size(gfile%recname)+8 endif !reclevtyp if( nummeta>3) then idisp=gfile%tlmeta iwrite=nemsio_charkind*size(gfile%reclevtyp) if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%reclevtyp,iwrite,MPI_CHARACTER,status,ios) if(ios<0) return idisp=idisp+nemsio_charkind*size(gfile%recname) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+nemsio_charkind*size(gfile%reclevtyp)+8 endif !reclev if( nummeta>4) then idisp=gfile%tlmeta iwrite=nemsio_intkind*size(gfile%reclev) if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) call byteswap(gfile%reclev,nemsio_intkind,size(gfile%reclev)) call mpi_file_write_at(gfile%fh,idisp,gfile%reclev,size(gfile%reclev),MPI_INTEGER,status,ios) if(ios<0) return idisp=idisp+nemsio_intkind*size(gfile%reclev) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+nemsio_intkind*size(gfile%reclev)+8 endif !vcoord if ( nummeta>5 ) then idisp=gfile%tlmeta iwrite=nemsio_realkind*size(gfile%vcoord) if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) call byteswap(gfile%vcoord,nemsio_realkind,size(gfile%vcoord)) call mpi_file_write_at(gfile%fh,idisp,gfile%vcoord,size(gfile%vcoord),MPI_REAL,status,ios) if(ios<0) return if(gfile%do_byteswap) call byteswap(gfile%vcoord,nemsio_realkind,size(gfile%vcoord)) idisp=idisp+nemsio_realkind*size(gfile%vcoord) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%vcoord)+8 endif !lat if ( nummeta>6 ) then idisp=gfile%tlmeta iwrite=nemsio_realkind*size(gfile%lat) if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) call byteswap(gfile%lat,nemsio_realkind,size(gfile%lat)) call mpi_file_write_at(gfile%fh,idisp,gfile%lat,gfile%fieldsize,MPI_REAL,status,ios) if(ios<0) return if(gfile%do_byteswap) call byteswap(gfile%lat,nemsio_realkind,size(gfile%lat)) idisp=idisp+nemsio_realkind*size(gfile%lat) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%lat)+8 endif !lon if ( nummeta>7 ) then idisp=gfile%tlmeta iwrite=nemsio_realkind*size(gfile%lon) if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) call byteswap(gfile%lon,nemsio_realkind,size(gfile%lon)) call mpi_file_write_at(gfile%fh,idisp,gfile%lon,gfile%fieldsize,MPI_REAL,status,ios) if(ios<0) return if(gfile%do_byteswap) call byteswap(gfile%lon,nemsio_realkind,size(gfile%lon)) idisp=idisp+nemsio_realkind*size(gfile%lon) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%lat)+8 ! print *,'tlmetreclon=',gfile%tlmeta,'nwrite=',nwrite endif !dx if ( nummeta>8 ) then idisp=gfile%tlmeta iwrite=nemsio_realkind*size(gfile%dx) if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) call byteswap(gfile%dx,nemsio_realkind,size(gfile%dx)) call mpi_file_write_at(gfile%fh,idisp,gfile%dx,gfile%fieldsize,MPI_REAL,status,ios) if(ios<0) return if(gfile%do_byteswap) call byteswap(gfile%dx,nemsio_realkind,size(gfile%dx)) idisp=idisp+nemsio_realkind*size(gfile%dx) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%dx)+8 endif !dy if ( nummeta>9 ) then idisp=gfile%tlmeta iwrite=nemsio_realkind*size(gfile%dy) if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) call byteswap(gfile%dy,nemsio_realkind,size(gfile%dy)) call mpi_file_write_at(gfile%fh,idisp,gfile%dy,gfile%fieldsize,MPI_REAL,status,ios) if(ios<0) return if(gfile%do_byteswap) call byteswap(gfile%dy,nemsio_realkind,size(gfile%dy)) idisp=idisp+nemsio_realkind*size(gfile%dy) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%dy)+8 ! print *,'tlmetrecdy=',gfile%tlmeta,'nwrite=',nwrite endif !Cpi if ( nummeta>10 ) then idisp=gfile%tlmeta iwrite=nemsio_realkind*size(gfile%cpi) if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) call byteswap(gfile%cpi,nemsio_realkind,size(gfile%cpi)) call mpi_file_write_at(gfile%fh,idisp,gfile%cpi,size(gfile%cpi),MPI_REAL,status,ios) if(ios<0) return if(gfile%do_byteswap) call byteswap(gfile%cpi,nemsio_realkind,size(gfile%cpi)) idisp=idisp+nemsio_realkind*size(gfile%cpi) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%cpi)+8 endif !Ri if ( nummeta>11 ) then idisp=gfile%tlmeta iwrite=nemsio_realkind*size(gfile%ri) if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) call byteswap(gfile%ri,nemsio_realkind,size(gfile%ri)) call mpi_file_write_at(gfile%fh,idisp,gfile%ri,size(gfile%ri),MPI_REAL,status,ios) if(ios<0) return if(gfile%do_byteswap) call byteswap(gfile%ri,nemsio_realkind,size(gfile%ri)) idisp=idisp+nemsio_realkind*size(gfile%ri) call mpi_file_write_at(gfile%fh,idisp,iwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%ri)+8 endif !------------------------------------------------------------ ! write out extra meta data record !------------------------------------------------------------ if(gfile%extrameta) then meta3%nmetavari=gfile%nmetavari meta3%nmetavarr=gfile%nmetavarr meta3%nmetavarl=gfile%nmetavarl meta3%nmetavarc=gfile%nmetavarc meta3%nmetaaryi=gfile%nmetaaryi meta3%nmetaaryr=gfile%nmetaaryr meta3%nmetaaryl=gfile%nmetaaryl meta3%nmetaaryc=gfile%nmetaaryc meta3%nmetavarr8=gfile%nmetavarr8 meta3%nmetaaryr8=gfile%nmetaaryr8 idisp=gfile%tlmeta !!!!!####!!now iwritewill be nemsio_lmeta3 if(gfile%nmetavarr8>0.or.gfile%nmetaaryr8>0) then iwrite=nemsio_lmeta3 else iwrite=nemsio_lmeta3-8 endif nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(meta3%nmetavari,nemsio_intkind,iwrite/4) call mpi_file_write_at(gfile%fh,idisp,meta3,iwrite/4,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(meta3%nmetavari,nemsio_intkind,iwrite/4) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 ! print *,'tlmetameta3=',gfile%tlmeta,'nmetavari=',gfile%nmetavari,gfile%nmetavarr, & ! gfile%nmetavarl,gfile%nmetavarc,gfile%nmetavarr8,'nmetaaryi=',gfile%nmetaaryi, & ! gfile%nmetaaryr,gfile%nmetaaryl,gfile%nmetaaryc,gfile%nmetaaryr8,'iwrite=',iwrite ! !-- write meta var integer if (gfile%nmetavari.gt.0) then idisp=gfile%tlmeta iwrite=len(gfile%variname)*gfile%nmetavari nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%variname,iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 ! idisp=gfile%tlmeta iwrite=gfile%nmetavari nwrite=iwrite*kind(gfile%varival) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%varival,nemsio_intkind,size(gfile%varival)) call mpi_file_write_at(gfile%fh,idisp,gfile%varival,iwrite,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%varival,nemsio_intkind,size(gfile%varival)) idisp=idisp+iwrite*kind(gfile%varival) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%varival)+8 endif !var real4 if (gfile%nmetavarr.gt.0) then idisp=gfile%tlmeta iwrite=len(gfile%varrname)*gfile%nmetavarr nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%varrname,iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 idisp=gfile%tlmeta iwrite=gfile%nmetavarr nwrite=iwrite*kind(gfile%varrval) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%varrval,nemsio_realkind,size(gfile%varrval)) call mpi_file_write_at(gfile%fh,idisp,gfile%varrval,iwrite,MPI_REAL,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%varrval,nemsio_realkind,size(gfile%varrval)) idisp=idisp+iwrite*kind(gfile%varrval) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%varrval)+8 endif !var logical if (gfile%nmetavarl.gt.0) then idisp=gfile%tlmeta iwrite=len(gfile%varlname)*gfile%nmetavarl nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%varlname,iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 idisp=gfile%tlmeta iwrite=gfile%nmetavarl nwrite=iwrite*kind(gfile%varlval) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%varlval,nemsio_logickind,size(gfile%varlval)) call mpi_file_write_at(gfile%fh,idisp,gfile%varlval,iwrite,MPI_LOGICAL,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%varlval,nemsio_logickind,size(gfile%varlval)) idisp=idisp+iwrite*kind(gfile%varlval) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%varlval)+8 endif !var character if (gfile%nmetavarc.gt.0) then idisp=gfile%tlmeta iwrite=len(gfile%varcname)*gfile%nmetavarc nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%varcname,iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 idisp=gfile%tlmeta iwrite=gfile%nmetavarc*len(gfile%varcval) nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%varcval,iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 endif !var real8 if (gfile%nmetavarr8.gt.0) then idisp=gfile%tlmeta iwrite=len(gfile%varr8name)*gfile%nmetavarr8 nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%varr8name,iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 idisp=gfile%tlmeta iwrite=gfile%nmetavarr8 nwrite=iwrite*kind(gfile%varr8val) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%varr8val,nemsio_dblekind,size(gfile%varr8val)) call mpi_file_write_at(gfile%fh,idisp,gfile%varr8val,iwrite,MPI_REAL8,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%varr8val,nemsio_dblekind,size(gfile%varr8val)) idisp=idisp+iwrite*kind(gfile%varr8val) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%varr8val)+8 endif !meta arr integer if (gfile%nmetaaryi.gt.0) then idisp=gfile%tlmeta iwrite=len(gfile%aryiname)*gfile%nmetaaryi nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%aryiname,iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 idisp=gfile%tlmeta iwrite=gfile%nmetaaryi nwrite=iwrite*kind(gfile%aryilen) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%aryilen,nemsio_intkind,size(gfile%aryilen)) call mpi_file_write_at(gfile%fh,idisp,gfile%aryilen,iwrite,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryilen,nemsio_intkind,size(gfile%aryilen)) idisp=idisp+iwrite*kind(gfile%aryilen) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryilen)+8 ! do i=1,gfile%nmetaaryi idisp=gfile%tlmeta iwrite=gfile%aryilen(i) nwrite=iwrite*kind(gfile%aryival) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%aryival(1:iwrite,i),nemsio_intkind,gfile%aryilen(i)) call mpi_file_write_at(gfile%fh,idisp,gfile%aryival(1:iwrite,i),iwrite,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryival(1:iwrite,i),nemsio_intkind,gfile%aryilen(i)) idisp=idisp+iwrite*kind(gfile%aryival) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryival)+8 enddo endif !meta arr real if (gfile%nmetaaryr.gt.0) then idisp=gfile%tlmeta iwrite=len(gfile%aryrname)*gfile%nmetaaryr nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%aryrname,iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 idisp=gfile%tlmeta iwrite=gfile%nmetaaryr nwrite=iwrite*kind(gfile%aryrlen) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%aryrlen,nemsio_intkind,size(gfile%aryrlen)) call mpi_file_write_at(gfile%fh,idisp,gfile%aryrlen,iwrite,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryrlen,nemsio_intkind,size(gfile%aryrlen)) idisp=idisp+iwrite*kind(gfile%aryrlen) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryrlen)+8 ! do i=1,gfile%nmetaaryr idisp=gfile%tlmeta iwrite=gfile%aryrlen(i) nwrite=iwrite*kind(gfile%aryrval) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%aryrval(1:iwrite,i),nemsio_realkind,gfile%aryrlen(i)) call mpi_file_write_at(gfile%fh,idisp,gfile%aryrval(1:iwrite,i),iwrite,MPI_REAL,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryrval(1:iwrite,i),nemsio_realkind,gfile%aryrlen(i)) idisp=idisp+iwrite*kind(gfile%aryrval) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryrval)+8 enddo endif !meta arr logical if (gfile%nmetaaryl.gt.0) then idisp=gfile%tlmeta iwrite=len(gfile%arylname)*gfile%nmetaaryl nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%arylname,iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 idisp=gfile%tlmeta iwrite=gfile%nmetaaryl nwrite=iwrite*kind(gfile%aryllen) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%aryllen,nemsio_intkind,size(gfile%aryllen)) call mpi_file_write_at(gfile%fh,idisp,gfile%aryllen,iwrite,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryllen,nemsio_intkind,size(gfile%aryllen)) idisp=idisp+iwrite*kind(gfile%aryllen) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryllen)+8 do i=1,gfile%nmetaaryl idisp=gfile%tlmeta iwrite=gfile%aryllen(i) nwrite=iwrite*kind(gfile%arylval) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%arylval(1:iwrite,i),nemsio_logickind,gfile%aryllen(i)) call mpi_file_write_at(gfile%fh,idisp,gfile%arylval(1:iwrite,i),iwrite,MPI_LOGICAL,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%arylval(1:iwrite,i),nemsio_logickind,gfile%aryllen(i)) idisp=idisp+iwrite*kind(gfile%arylval) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%arylval)+8 enddo endif !meta arr char if (gfile%nmetaaryc.gt.0) then idisp=gfile%tlmeta iwrite=len(gfile%arycname)*gfile%nmetaaryc nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%arycname,iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 idisp=gfile%tlmeta iwrite=gfile%nmetaaryc nwrite=iwrite*kind(gfile%aryclen) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%aryclen,nemsio_intkind,size(gfile%aryclen)) call mpi_file_write_at(gfile%fh,idisp,gfile%aryclen,iwrite,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryclen,nemsio_intkind,size(gfile%aryclen)) idisp=idisp+iwrite*kind(gfile%aryclen) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryclen)+8 do i=1,gfile%nmetaaryc idisp=gfile%tlmeta iwrite=gfile%aryclen(i)*len(gfile%arycval) nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%arycval(1:iwrite,i),iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 enddo endif !meta arr real8 if (gfile%nmetaaryr8.gt.0) then idisp=gfile%tlmeta iwrite=len(gfile%aryr8name)*gfile%nmetaaryr8 nwrite=iwrite if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 call mpi_file_write_at(gfile%fh,idisp,gfile%aryr8name,iwrite,MPI_CHARACTER,status,ios) idisp=idisp+iwrite call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite+8 idisp=gfile%tlmeta iwrite=gfile%nmetaaryr8 nwrite=iwrite*kind(gfile%aryr8len) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%aryr8len,nemsio_intkind,size(gfile%aryr8len)) call mpi_file_write_at(gfile%fh,idisp,gfile%aryr8len,iwrite,MPI_INTEGER,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryr8len,nemsio_intkind,size(gfile%aryr8len)) idisp=idisp+iwrite*kind(gfile%aryr8len) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryr8len)+8 do i=1,gfile%nmetaaryr8 idisp=gfile%tlmeta iwrite=gfile%aryr8len(i) nwrite=iwrite*kind(gfile%aryr8val) if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) idisp=idisp+4 if(gfile%do_byteswap) & call byteswap(gfile%aryr8val(1:iwrite,i),nemsio_dblekind,gfile%aryr8len(i)) call mpi_file_write_at(gfile%fh,idisp,gfile%aryr8val(1:iwrite,i),iwrite,MPI_REAL8,status,ios) if(gfile%do_byteswap) & call byteswap(gfile%aryr8val(1:iwrite,i),nemsio_dblekind,gfile%aryr8len(i)) idisp=idisp+iwrite*kind(gfile%aryr8val) call mpi_file_write_at(gfile%fh,idisp,nwrite,1,MPI_INTEGER,status,ios) gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryr8val)+8 enddo endif endif !end of gfile%extrameta ! endif !end of lead_task !mpi call MPI_Barrier(gfile%mpi_comm, ios) call mpi_bcast(gfile%tlmeta,1,MPI_INTEGER8,gfile%lead_task,gfile%mpi_comm,ios) ! write(0,*)'after mpi_bcasttlmeta,',gfile%tlmeta, 'end of wcreate,ios=',ios ! iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine nemsio_wcreate !------------------------------------------------------------------------------ subroutine nemsio_getfilehead(gfile,iret,gtype,gdatatype,gfname,gaction, & modelname,version,nmeta,lmeta,nrec,idate,nfday,nfhour,nfminute, & nfsecondn,nfsecondd,dimx,dimy,dimz,nframe,nsoil,ntrac,ncldt,jcap,& idvc,idsl,idvm,idrt, rlon_min,rlon_max,rlat_min,rlat_max,tlmeta, & file_endian,do_byteswap, & extrameta,nmetavari,nmetavarr,nmetavarl,nmetavarc,nmetavarr8, & nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc,nmetaaryr8, & recname,reclevtyp,reclev,vcoord,lon,lat,dx,dy,cpi,ri, & variname,varival,varrname,varrval,varlname,varlval,varcname,varcval, & varr8name,varr8val, & aryiname,aryilen,aryival,aryrname,aryrlen,aryrval, & arylname,aryllen,arylval,arycname,aryclen,arycval, & aryr8name,aryr8len,aryr8val ) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: get nemsio meta data information from outside !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile integer(nemsio_intkind),optional,intent(out) :: iret character*(*),optional,intent(out) :: gtype,gdatatype,gfname, & gaction,modelname integer(nemsio_intkind),optional,intent(out) :: version,nmeta,lmeta,tlmeta integer(nemsio_realkind),optional,intent(out):: nrec,idate(7),nfday,nfhour, & nfminute,nfsecondn,nfsecondd integer(nemsio_realkind),optional,intent(out):: dimx,dimy,dimz,nframe, & nsoil,ntrac integer(nemsio_realkind),optional,intent(out):: ncldt,jcap,idvc,idsl,idvm,idrt real(nemsio_realkind),optional,intent(out) :: rlon_min,rlon_max,rlat_min, & rlat_max character*(*),optional,intent(out) :: file_endian logical(nemsio_logickind),optional,intent(out):: do_byteswap logical(nemsio_logickind),optional,intent(out):: extrameta integer(nemsio_realkind),optional,intent(out):: nmetavari,nmetavarr, & nmetavarl,nmetavarc,nmetaaryi, & nmetaaryr,nmetaaryl,nmetaaryc, & nmetavarr8,nmetaaryr8 character(*),optional,intent(out) :: recname(:) character(*),optional,intent(out) :: reclevtyp(:) integer(nemsio_intkind),optional,intent(out) :: reclev(:) real(nemsio_realkind),optional,intent(out) :: vcoord(:,:,:) real(nemsio_realkind),optional,intent(out) :: lat(:),lon(:) real(nemsio_realkind),optional,intent(out) :: dx(:),dy(:) real(nemsio_realkind),optional,intent(out) :: Cpi(:),Ri(:) character(*),optional,intent(out) :: variname(:),varrname(:) character(*),optional,intent(out) :: varlname(:),varcname(:) character(*),optional,intent(out) :: varr8name(:) character(*),optional,intent(out) :: aryiname(:),aryrname(:) character(*),optional,intent(out) :: arylname(:),arycname(:) character(*),optional,intent(out) :: aryr8name(:) integer(nemsio_intkind),optional,intent(out) :: aryilen(:),aryrlen(:) integer(nemsio_intkind),optional,intent(out) :: aryllen(:),aryclen(:) integer(nemsio_intkind),optional,intent(out) :: aryr8len(:) integer(nemsio_intkind),optional,intent(out) :: varival(:),aryival(:,:) real(nemsio_realkind),optional,intent(out) :: varrval(:),aryrval(:,:) real(nemsio_dblekind),optional,intent(out) :: varr8val(:),aryr8val(:,:) logical(nemsio_logickind),optional,intent(out):: varlval(:),arylval(:,:) character(*),optional,intent(out) :: varcval(:),arycval(:,:) integer ios,i !------------------------------------------------------------ if (present(iret)) iret=-3 if(present(gtype)) gtype=gfile%gtype if(present(gdatatype)) gdatatype=gfile%gdatatype if(present(gfname)) gfname=trim(gfile%gfname) if(present(gaction)) gaction=gfile%gaction if(present(modelname)) modelname=gfile%modelname if(present(version)) version=gfile%version if(present(nmeta)) nmeta=gfile%nmeta if(present(lmeta)) lmeta=gfile%lmeta if(present(nrec)) nrec=gfile%nrec if(present(nfday)) nfday=gfile%nfday if(present(nfhour)) nfhour=gfile%nfhour if(present(nfminute)) nfminute=gfile%nfminute if(present(nfsecondn)) nfsecondn=gfile%nfsecondn if(present(nfsecondd)) nfsecondd=gfile%nfsecondd if(present(idate)) idate(1:7)=gfile%idate(1:7) if(present(dimx)) dimx=gfile%dimx if(present(dimy)) dimy=gfile%dimy if(present(dimz)) dimz=gfile%dimz if(present(nframe)) nframe=gfile%nframe if(present(nsoil)) nsoil=gfile%nsoil if(present(ntrac)) ntrac=gfile%ntrac if(present(jcap)) jcap=gfile%jcap if(present(ncldt)) ncldt=gfile%ncldt if(present(idvc)) idvc=gfile%idvc if(present(idsl)) idsl=gfile%idsl if(present(idvm)) idvm=gfile%idvm if(present(idrt)) idrt=gfile%idrt if(present(rlon_min)) rlon_min=gfile%rlon_min if(present(rlon_max)) rlon_max=gfile%rlon_max if(present(rlat_min)) rlat_min=gfile%rlat_min if(present(rlat_max)) rlat_max=gfile%rlat_max if(present(rlat_max)) rlat_max=gfile%rlat_max if(present(tlmeta)) tlmeta=gfile%tlmeta if(present(file_endian)) file_endian=gfile%file_endian if(present(do_byteswap)) do_byteswap=gfile%do_byteswap if(present(extrameta)) extrameta=gfile%extrameta ! ! print *,'in getfilehead, 1extrameta=',gfile%extrameta, & ! 'nrec=',gfile%nrec,'size(recname)=',size(recname), & ! size(reclevtyp),size(reclev) !--- rec if(present(recname) ) then if (gfile%nrec.ne.size(recname)) then if ( present(iret)) return call nemsio_stop else recname=gfile%recname endif endif if(present(reclevtyp)) then if (gfile%nrec.ne.size(reclevtyp)) then if ( present(iret)) return call nemsio_stop else reclevtyp=gfile%reclevtyp endif endif if(present(reclev) ) then if (gfile%nrec.ne.size(reclev)) then if ( present(iret)) return call nemsio_stop else reclev=gfile%reclev endif endif !--- vcoord if(present(vcoord)) then if (size(vcoord) .ne. (gfile%dimz+1)*2*3 ) then if ( present(iret)) return call nemsio_stop else vcoord=gfile%vcoord endif endif !--- lat if(present(lat) ) then if (size(lat).ne.gfile%fieldsize) then print *,'WRONG: size(lat)=',size(lat),' is not equal to ',gfile%fieldsize if ( present(iret)) return call nemsio_stop else lat=gfile%lat endif endif !--- lon if(present(lon) ) then if (size(lon).ne.gfile%fieldsize) then print *,'WRONG: size(lon)=',size(lon),' is not equal to ',gfile%fieldsize if ( present(iret)) return call nemsio_stop else lon=gfile%lon endif endif !--- dx if(present(dx) ) then ! print *,'getfilehead, size(dx)=',size(dx),gfile%fieldsize, & ! maxval(gfile%dx),minval(gfile%dx) if (size(dx).ne.gfile%fieldsize) then print *,'WRONG: size(dX)=',size(dx),' is not equal to ',gfile%fieldsize if ( present(iret)) return call nemsio_stop else dx=gfile%dx endif endif if(present(dy) ) then if (size(dy).ne.gfile%fieldsize) then print *,'WRONG: size(dy)=',size(dy),' is not equal to ',gfile%fieldsize if ( present(iret)) return call nemsio_stop else dy=gfile%dy endif endif !--- Cpi if(present(Cpi) ) then if (gfile%ntrac+1.ne.size(Cpi)) then if ( present(iret)) return call nemsio_stop else Cpi=gfile%Cpi endif endif !Ri if(present(Ri) ) then if (gfile%ntrac+1.ne.size(Ri)) then if ( present(iret)) return call nemsio_stop else Ri=gfile%Ri endif endif !------------------------------------------------------------------------------ !*** for extra meta field !------------------------------------------------------------------------------ !extrameta if (present(nmetavari) ) nmetavari=gfile%nmetavari if (present(nmetavarr) ) nmetavarr=gfile%nmetavarr if (present(nmetavarl) ) nmetavarl=gfile%nmetavarl if (present(nmetavarc) ) nmetavarc=gfile%nmetavarc if (present(nmetavarr8) ) nmetavarr8=gfile%nmetavarr8 if (present(nmetaaryi) ) nmetaaryi=gfile%nmetaaryi if (present(nmetaaryr) ) nmetaaryr=gfile%nmetaaryr if (present(nmetaaryl) ) nmetaaryl=gfile%nmetaaryl if (present(nmetaaryc) ) nmetaaryc=gfile%nmetaaryc if (present(nmetaaryr8) ) nmetaaryr8=gfile%nmetaaryr8 if ( gfile%nmetavari.gt.0 ) then if (present(variname)) then if(size(variname).eq.nmetavari) then do i=1,nmetavari variname(i)=gfile%variname(i) enddo endif endif if (present(varival)) then if(size(varival).eq.nmetavari) varival(1:nmetavari)=gfile%varival(1:nmetavari) endif endif if ( gfile%nmetavarr.gt.0 ) then if (present(varrname)) then if(size(varrname).eq.nmetavarr) varrname=gfile%varrname endif if (present(varrval)) then if(size(varrval).eq.nmetavarr) varrval=gfile%varrval endif endif if ( gfile%nmetavarl.gt.0 ) then if (present(varlname)) then if(size(varlname).eq.nmetavarl) varlname=gfile%varlname endif if (present(varlval)) then if(size(varlval).eq.nmetavarl) varlval=gfile%varlval endif endif if ( gfile%nmetavarc.gt.0 ) then if (present(varcname)) then if(size(varcname).eq.gfile%nmetavarc) varcname=gfile%varcname endif if (present(varcval)) then if(size(varcval).eq.gfile%nmetavarc) varcval=gfile%varcval endif endif if ( gfile%nmetavarr8.gt.0 ) then if (present(varr8name)) then if(size(varr8name).eq.gfile%nmetavarr8) varr8name=gfile%varr8name endif if (present(varr8val)) then if(size(varr8val).eq.gfile%nmetavarr8) varr8val=gfile%varr8val endif endif if ( gfile%nmetaaryi.gt.0 ) then if (present(aryiname)) then if(size(aryiname).eq.nmetaaryi) aryiname=gfile%aryiname endif if (present(aryilen)) then if(size(aryilen).eq.nmetaaryi) aryilen=gfile%aryilen endif if (present(aryival)) then if(size(aryival).eq.nmetaaryi*maxval(gfile%aryilen) ) & aryival=gfile%aryival endif endif if ( gfile%nmetaaryr.gt.0 ) then if (present(aryrname)) then if(size(aryrname).eq.nmetaaryr) aryrname=gfile%aryrname endif if (present(aryrlen)) then if(size(aryrlen).eq.nmetaaryr) aryrlen=gfile%aryrlen endif if (present(aryrval)) then if(size(aryrval).eq.nmetaaryr*maxval(gfile%aryrlen) ) & aryrval=gfile%aryrval endif endif if ( gfile%nmetaaryl.gt.0 ) then if (present(arylname)) then if(size(arylname).eq.nmetaaryl) arylname=gfile%arylname endif if (present(aryllen)) then if(size(aryllen).eq.nmetaaryl) aryllen=gfile%aryllen endif if (present(arylval) ) then if(size(arylval).eq.nmetaaryl*maxval(gfile%aryllen) ) & arylval=gfile%arylval endif endif if ( gfile%nmetaaryc.gt.0 ) then if (present(arycname)) then if(size(arycname).eq.gfile%nmetaaryc) arycname=gfile%arycname endif if (present(aryclen)) then if(size(aryclen).eq.gfile%nmetaaryc) aryclen=gfile%aryclen endif if (present(arycval)) then if(size(arycval).eq.gfile%nmetaaryc*maxval(gfile%aryclen) ) & arycval=gfile%arycval endif endif if ( gfile%nmetaaryr8.gt.0 ) then if (present(aryr8name)) then if( size(aryr8name).eq.gfile%nmetaaryr8) aryr8name=gfile%aryr8name endif if (present(aryr8len)) then if(size(aryr8len).eq.gfile%nmetaaryr8) aryr8len=gfile%aryr8len endif if (present(aryr8val)) then if(size(aryr8val).eq.gfile%nmetaaryr8*maxval(gfile%aryr8len) ) & aryr8val=gfile%aryr8val endif endif call mpi_barrier(gfile%mpi_comm,ios) if ( present(iret)) iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine nemsio_getfilehead !------------------------------------------------------------------------------ subroutine nemsio_getfheadvari(gfile,varname,varval,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: get meta data var value from file header !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile character(*), intent(in) :: varname integer(nemsio_intkind),intent(out) :: varval integer(nemsio_intkind),optional,intent(out) :: iret integer i,j !--- if(present(iret) ) iret=-17 do i=1,gfile%headvarinum if(equal_str_nocase(trim(varname),trim(gfile%headvariname(i))) ) then varval=gfile%headvarival(i) if(present(iret) ) iret=0 return endif enddo !--- if(gfile%nmetavari.gt.0) 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=0 return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadvari !------------------------------------------------------------------------------ subroutine nemsio_getfheadvarr(gfile,varname,varval,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: get meta data var value from file header !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile character(*), intent(in) :: varname real(nemsio_realkind),intent(out) :: varval integer(nemsio_intkind),optional,intent(out) :: iret integer i,j !--- if(present(iret) ) iret=-17 do i=1,gfile%headvarrnum if(equal_str_nocase(trim(varname),trim(gfile%headvarrname(i))) ) then varval=gfile%headvarrval(i) if(present(iret) ) iret=0 return endif enddo !--- if(gfile%nmetavarr.gt.0) 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=0 return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadvarr !------------------------------------------------------------------------------ subroutine nemsio_getfheadvarl(gfile,varname,varval,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: get meta data var value from file header !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile character(*), intent(in) :: varname logical(nemsio_logickind),intent(out) :: varval integer(nemsio_intkind),optional,intent(out) :: iret integer i,j !--- if(present(iret) ) iret=-17 if(gfile%nmetavarl.gt.0) 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=0 return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadvarl !------------------------------------------------------------------------------ subroutine nemsio_getfheadvarc(gfile,varname,varval,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: get meta data var value from file header !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile character(*), intent(in) :: varname character(*),intent(out) :: varval integer(nemsio_intkind),optional,intent(out) :: iret integer i,j !--- if(present(iret) ) iret=-17 do i=1,gfile%headvarcnum if(equal_str_nocase(trim(varname),trim(gfile%headvarcname(i))) ) then varval=gfile%headvarcval(i) if(present(iret) ) iret=0 return endif enddo !--- if(gfile%nmetavarc.gt.0) 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=0 return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadvarc !------------------------------------------------------------------------------ subroutine nemsio_getfheadvarr8(gfile,varname,varval,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: get meta data var value from file header !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile character(len=*), intent(in) :: varname real(nemsio_dblekind),intent(out) :: varval integer(nemsio_intkind),optional,intent(out) :: iret integer i,j !--- if(present(iret) ) iret=-17 !--- if(gfile%nmetavarr8.gt.0) then do i=1,gfile%nmetavarr8 if(equal_str_nocase(trim(varname),trim(gfile%varr8name(i))) ) then varval=gfile%varr8val(i) if(present(iret) ) iret=0 return endif enddo endif if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadvarr8 !------------------------------------------------------------------------------ subroutine nemsio_getfheadaryi(gfile,varname,varval,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: get meta data var value from file header !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile character(*), intent(in) :: varname integer(nemsio_intkind),intent(out) :: varval(:) integer(nemsio_intkind),optional,intent(out) :: iret integer i,j,ios !--- if(present(iret) ) iret=-17 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=0 return endif enddo !--- if(gfile%nmetaaryi.gt.0) 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=0 ios=0 return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadaryi !------------------------------------------------------------------------------ subroutine nemsio_getfheadaryr(gfile,varname,varval,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: get meta data var value from file header !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile character(*), intent(in) :: varname real(nemsio_realkind),intent(out) :: varval(:) integer(nemsio_intkind),optional,intent(out) :: iret integer i,j,ios !--- if(present(iret) ) iret=-17 if(gfile%headaryrnum>0) 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=0 return endif enddo endif !--- if(gfile%nmetaaryr.gt.0) 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=0 ios=0 return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadaryr !------------------------------------------------------------------------------ subroutine nemsio_getfheadaryl(gfile,varname,varval,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: get meta data var value from file header !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile character(*), intent(in) :: varname logical(nemsio_logickind),intent(out) :: varval(:) integer(nemsio_intkind),optional,intent(out) :: iret integer i,j,ios !--- if(present(iret) ) iret=-17 if(gfile%nmetaaryl.gt.0) 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=0 ios=0 return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadaryl !------------------------------------------------------------------------------ subroutine nemsio_getfheadaryc(gfile,varname,varval,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: get meta data var value from file header !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile character(*), intent(in) :: varname character(*),intent(out) :: varval(:) integer(nemsio_intkind),optional,intent(out) :: iret integer i,j,ios !--- if(present(iret) ) iret=-17 if(gfile%nmetaaryc.gt.0) then do i=1,gfile%nmetaaryc if(equal_str_nocase(trim(varname),trim(gfile%headarycname(i))) ) then varval(:)=gfile%headarycval(1:gfile%aryclen(i),i) if(present(iret) ) iret=0 return endif enddo endif !--- if(gfile%nmetaaryc.gt.0) 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=0 ios=0 return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadaryc !------------------------------------------------------------------------------ subroutine nemsio_getfheadaryr8(gfile,varname,varval,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: get meta data var value from file header !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile character(*), intent(in) :: varname real(nemsio_dblekind),intent(out) :: varval(:) integer(nemsio_intkind),optional,intent(out) :: iret integer i,j,ios !--- if(present(iret) ) iret=-17 !--- if(gfile%nmetaaryr8.gt.0) then do i=1,gfile%nmetaaryr8 if(equal_str_nocase(trim(varname),trim(gfile%aryr8name(i)))) then varval(:)=gfile%aryr8val(1:gfile%aryr8len(i),i) if(present(iret) ) iret=0 ios=0 return endif enddo endif !--- if(.not.present(iret) ) call nemsio_stop return end subroutine nemsio_getfheadaryr8 !------------------------------------------------------------------------------ !***************** read bin data set : ******************************** ! !------------------------------------------------------------------------------ subroutine nemsio_searchrecv(gfile,jrec,name,levtyp,lev,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: search rec number giving rec name, levtyp and lev !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile integer(nemsio_intkind),intent(out) :: jrec character(*),intent(in) :: name, levtyp integer(nemsio_intkind),intent(in) :: lev integer(nemsio_intkind),optional,intent(out) :: iret integer i, nsize iret=-11 jrec=0 do i=1,gfile%nrec if ( trim(name) .eq. trim(gfile%recname(i)) .and. & trim(levtyp) .eq. trim(gfile%reclevtyp(i)) .and. & lev .eq. gfile%reclev(i) ) then jrec=i exit endif enddo if ( jrec .ne.0 ) iret=0 ! return end subroutine nemsio_searchrecv !------------------------------------------------------------------------------ ! !***************** no read grb1 data set : ********************************** ! !------------------------------------------------------------------------------ !############################################################################## ! !***************** write data set : ******************************** ! !############################################################################## !------------------------------------------------------------------------------ !***************** write out bin data set : ******************************** !------------------------------------------------------------------------------ ! !***************** no write out grb data set : ******************************** ! !------------------------------------------------------------------------------ !------------------------------------------------------------------------------ subroutine nemsio_chkgfary(gfile,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: check if arrays in gfile is allocated and with right size !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret integer :: ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-2 if ( gfile%dimx .eq. nemsio_intfill .or. gfile%dimy .eq. nemsio_intfill & .or. gfile%dimz .eq. nemsio_intfill .or. gfile%nrec .eq. nemsio_intfill & .or. gfile%idate(1) .eq.nemsio_intfill .or. gfile%ntrac .eq.nemsio_intfill ) then return endif if (.not. allocated(gfile%vcoord) .or. size(gfile%vcoord).ne. & (gfile%dimz+1)*3*2 ) then call nemsio_almeta1(gfile,ios) if (ios .ne. 0) return endif if (.not.allocated(gfile%lat) .or. size(gfile%lat).ne.gfile%fieldsize .or.& .not.allocated(gfile%lon) .or. size(gfile%lon).ne.gfile%fieldsize .or.& .not.allocated(gfile%dx) .or. size(gfile%dx).ne.gfile%fieldsize .or.& .not.allocated(gfile%dy) .or. size(gfile%dy).ne.gfile%fieldsize) then call nemsio_almeta2(gfile,ios) if (ios .ne. 0) return endif if (.not.allocated(gfile%Cpi) .or. size(gfile%Cpi).ne.gfile%ntrac+1 .or. & .not.allocated(gfile%Ri) .or. size(gfile%Ri).ne.gfile%ntrac+1 ) then call nemsio_almeta3(gfile,ios) if (ios .ne. 0) return endif if (allocated(gfile%recname) .and. size(gfile%recname).eq.gfile%nrec)& then if (allocated(gfile%reclevtyp) .and. size(gfile%reclevtyp) & .eq.gfile%nrec) then if (allocated(gfile%reclev) .and. size(gfile%reclev).eq. & gfile%nrec) then iret=0 return endif endif endif call nemsio_almeta4(gfile,ios) if (ios .ne. 0) return iret=0 end subroutine nemsio_chkgfary !------------------------------------------------------------------------------ subroutine nemsio_almeta(gfile,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: allocate all the arrays in gfile !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret integer ::dimvcoord1,dimvcoord2,dimnmmlev integer ::dimrecname,dimreclevtyp,dimreclev integer ::dimfield integer ::dimcpr integer ::iret1,iret2,iret3,iret4 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dimvcoord1=gfile%dimz+1 dimrecname=gfile%nrec dimreclevtyp=gfile%nrec dimreclev=gfile%nrec dimfield=gfile%fieldsize dimcpr=gfile%ntrac+1 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) allocate(gfile%recname(dimrecname), gfile%reclevtyp(dimreclevtyp), & gfile%reclev(dimreclev), & stat=iret1) allocate(gfile%vcoord(dimvcoord1,3,2) ,stat=iret2) allocate(gfile%lat(dimfield), gfile%lon(dimfield), & gfile%dx(dimfield), gfile%dy(dimfield) ,stat=iret3) allocate(gfile%Cpi(dimcpr), gfile%Ri(dimcpr), stat=iret4) iret=abs(iret1)+abs(iret2)+abs(iret3)+abs(iret4) if(iret.eq.0) then gfile%reclev=nemsio_intfill gfile%recname=' ' gfile%reclevtyp=' ' gfile%vcoord=nemsio_realfill gfile%lat=nemsio_realfill gfile%lon=nemsio_realfill gfile%dx=nemsio_realfill gfile%dy=nemsio_realfill gfile%Cpi=nemsio_realfill gfile%Ri=nemsio_realfill endif if(iret.ne.0) iret=-6 end subroutine nemsio_almeta !------------------------------------------------------------------------------ subroutine nemsio_alextrameta(gfile,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: allocate all the arrays in gfile !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret integer ::iret1,iret2,iret3,iret4 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-6 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.gt.0) 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.ne.0) return endif if(gfile%nmetavarr.gt.0) 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.ne.0) return endif if(gfile%nmetavarl.gt.0) 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.ne.0) return endif if(gfile%nmetavarc.gt.0) 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.ne.0) return endif if(gfile%nmetavarr8.gt.0) then if(allocated(gfile%varr8name)) deallocate(gfile%varr8name) if(allocated(gfile%varr8val)) deallocate(gfile%varr8val) allocate(gfile%varr8name(gfile%nmetavarr8), & gfile%varr8val(gfile%nmetavarr8), stat=iret1 ) if(iret1.ne.0) return endif if(gfile%nmetaaryi.gt.0) 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.ne.0) return endif if(gfile%nmetaaryr.gt.0) 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.ne.0) return endif if(gfile%nmetaaryl.gt.0) 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.ne.0) return endif if(gfile%nmetaaryc.gt.0) 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.ne.0) return endif if(gfile%nmetaaryr8.gt.0) then if(allocated(gfile%aryr8name)) deallocate(gfile%aryr8name) if(allocated(gfile%aryr8len)) deallocate(gfile%aryr8len) if(allocated(gfile%aryr8val)) deallocate(gfile%aryr8val) allocate(gfile%aryr8name(gfile%nmetaaryr8), & gfile%aryr8len(gfile%nmetaaryr8), stat=iret1 ) if(iret1.ne.0) return endif endif iret=0 end subroutine nemsio_alextrameta !------------------------------------------------------------------------------ subroutine nemsio_almeta1(gfile,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: allocate vcoord in gfile !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret integer :: dimvcoord1,dimnmmlev,dimnmmnsoil integer :: dimgsilev ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dimvcoord1=gfile%dimz+1 if(allocated(gfile%vcoord)) deallocate(gfile%vcoord) allocate(gfile%vcoord(dimvcoord1,3,2), stat=iret) if(iret.eq.0) then gfile%vcoord=nemsio_realfill endif if(iret.ne.0) iret=-6 end subroutine nemsio_almeta1 !------------------------------------------------------------------------------ subroutine nemsio_almeta2(gfile,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: allocate lat1d in gfile !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret integer :: 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.eq.0) then gfile%lat=nemsio_realfill gfile%lon=nemsio_realfill gfile%dx=nemsio_realfill gfile%dy=nemsio_realfill endif if(iret.ne.0) iret=-6 end subroutine nemsio_almeta2 !------------------------------------------------------------------------------ subroutine nemsio_almeta3(gfile,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: allocate lon1d in gfile !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret integer :: dim1d ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dim1d=gfile%ntrac+1 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.eq.0) then gfile%Cpi=nemsio_realfill gfile%Ri=nemsio_realfill endif if(iret.ne.0) iret=-6 end subroutine nemsio_almeta3 !------------------------------------------------------------------------------ subroutine nemsio_almeta4(gfile,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: allocate recnam, reclvevtyp, and reclev in gfile !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret integer :: dimrecname,dimreclevtyp,dimreclev ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - dimrecname=gfile%nrec dimreclevtyp=gfile%nrec dimreclev=gfile%nrec if(allocated(gfile%recname)) deallocate(gfile%recname) if(allocated(gfile%reclevtyp)) deallocate(gfile%reclevtyp) if(allocated(gfile%reclev)) deallocate(gfile%reclev) allocate(gfile%recname(dimrecname), gfile%reclevtyp(dimreclevtyp), & gfile%reclev(dimreclev), stat=iret) if(iret.eq.0) then gfile%reclev=nemsio_intfill gfile%recname=' ' gfile%reclevtyp=' ' endif if(iret.ne.0) iret=-6 end subroutine nemsio_almeta4 !------------------------------------------------------------------------------ subroutine nemsio_axmeta(gfile,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: empty gfile variables and decallocate arrays in gfile !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-6 gfile%gtype=' ' gfile%gdatatype=' ' gfile%modelname=' ' gfile%version=nemsio_intfill gfile%nmeta=nemsio_intfill gfile%lmeta=nemsio_intfill gfile%nrec=nemsio_intfill gfile%idate(1:7)=nemsio_intfill gfile%nfday=nemsio_intfill gfile%nfhour=nemsio_intfill gfile%nfminute=nemsio_intfill gfile%nfsecondn=nemsio_intfill gfile%nfsecondd=nemsio_intfill gfile%dimx=nemsio_intfill gfile%dimy=nemsio_intfill gfile%dimz=nemsio_intfill gfile%nframe=nemsio_intfill gfile%nsoil=nemsio_intfill gfile%ntrac=nemsio_intfill gfile%jcap=nemsio_intfill gfile%ncldt=nemsio_intfill gfile%idvc=nemsio_intfill gfile%idsl=nemsio_intfill gfile%idvm=nemsio_intfill gfile%idrt=nemsio_intfill gfile%rlon_min=nemsio_realfill gfile%rlon_max=nemsio_realfill gfile%rlat_min=nemsio_realfill gfile%rlat_max=nemsio_realfill gfile%extrameta=nemsio_logicfill gfile%nmetavari=nemsio_intfill gfile%nmetavarr=nemsio_intfill gfile%nmetavarl=nemsio_intfill gfile%nmetavarc=nemsio_intfill gfile%nmetaaryi=nemsio_intfill gfile%nmetaaryr=nemsio_intfill gfile%nmetaaryl=nemsio_intfill gfile%nmetaaryc=nemsio_intfill 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) ! gfile%mbuf=0 gfile%nnum=0 gfile%nlen=0 gfile%mnum=0 if(allocated(gfile%cbuf)) deallocate(gfile%cbuf) if(allocated(gfile%headvariname)) deallocate(gfile%headvariname) if(allocated(gfile%headvarrname)) deallocate(gfile%headvarrname) if(allocated(gfile%headvarlname)) deallocate(gfile%headvarlname) if(allocated(gfile%headvarcname)) deallocate(gfile%headvarcname) if(allocated(gfile%headvarival)) deallocate(gfile%headvarival) if(allocated(gfile%headvarrval)) deallocate(gfile%headvarrval) if(allocated(gfile%headvarlval)) deallocate(gfile%headvarlval) if(allocated(gfile%headvarcval)) deallocate(gfile%headvarcval) if(allocated(gfile%headaryiname)) deallocate(gfile%headaryiname) if(allocated(gfile%headaryrname)) deallocate(gfile%headaryrname) if(allocated(gfile%headarycname)) deallocate(gfile%headarycname) if(allocated(gfile%headaryival)) deallocate(gfile%headaryival) if(allocated(gfile%headaryrval)) deallocate(gfile%headaryrval) if(allocated(gfile%headarycval)) deallocate(gfile%headarycval) iret=0 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end subroutine nemsio_axmeta !------------------------------------------------------------------------------ subroutine nemsio_setfhead(gfile,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: required file header (default) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret integer(nemsio_intkind) i,j,k ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - iret=-17 gfile%headvarinum=29 gfile%headvarrnum=4 gfile%headvarlnum=1 gfile%headvarcnum=3 gfile%headaryinum=2 gfile%headaryrnum=7 gfile%headarycnum=2 ! 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 ! write(0,*)'before setfhead, headvarl,nrec=',gfile%nrec allocate(gfile%headvarlname(gfile%headvarlnum),gfile%headvarlval(gfile%headvarlnum) ) gfile%headvarlname(1)='extrameta' gfile%headvarlval(1)=gfile%extrameta ! !--- gfile%head int ary ! write(0,*)'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) gfile%headaryiname(2)='reclev' if(allocated(gfile%reclev)) gfile%headaryival(:,2)=gfile%reclev(:) ! !--- gfile%head real ary ! write(0,*)'before setfhead, headaryr,',gfile%headaryrnum ,gfile%fieldsize allocate(gfile%headaryrname(gfile%headaryrnum) ) allocate(gfile%headaryrval(max(gfile%fieldsize,(gfile%dimz+1)*6),gfile%headaryrnum)) gfile%headaryrname(1)='vcoord' if(allocated(gfile%vcoord)) then do j=1,2 do i=1,3 do k=1,gfile%dimz+1 gfile%headaryrval(k+((j-1)*3+i-1)*(gfile%dimz+1),1)=gfile%vcoord(k,i,j) enddo enddo enddo endif gfile%headaryrname(2)='lat' if(allocated(gfile%lat)) gfile%headaryrval(:,2)=gfile%lat gfile%headaryrname(3)='lon' if(allocated(gfile%lon)) gfile%headaryrval(:,3)=gfile%lon gfile%headaryrname(4)='dx' if(allocated(gfile%dx)) gfile%headaryrval(:,4)=gfile%dx gfile%headaryrname(5)='dy' if(allocated(gfile%dy)) gfile%headaryrval(:,5)=gfile%dy gfile%headaryrname(6)='cpi' if(allocated(gfile%cpi)) gfile%headaryrval(1:size(gfile%cpi),6)=gfile%cpi(:) gfile%headaryrname(7)='ri' if(allocated(gfile%ri)) gfile%headaryrval(1:size(gfile%ri),7)=gfile%ri(:) ! !--- gfile%head char var ! write(0,*)'before setfhead, headaryc,nrec=',gfile%nrec,gfile%headarycnum allocate(gfile%headarycname(gfile%headarycnum) ) if(size(gfile%recname)>0) then allocate(gfile%headarycval(size(gfile%recname),gfile%headarycnum)) gfile%headarycname(1)='recname' if(allocated(gfile%recname)) gfile%headarycval(:,1)=gfile%recname gfile%headarycname(2)='reclevtyp' if(allocated(gfile%reclevtyp)) gfile%headarycval(:,2)=gfile%reclevtyp endif ! ! write(0,*)'end ef nemsio_setfhead' iret=0 end subroutine nemsio_setfhead !------------------------------------------------------------------------------ subroutine nemsio_getrechead(gfile,jrec,name,levtyp,lev,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: given record number, return users record name, lev typ, and levs !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(in) :: gfile integer(nemsio_intkind),intent(in) :: jrec character*(*),intent(out) :: name,levtyp integer(nemsio_intkind),intent(out) :: lev integer(nemsio_intkind),optional,intent(out) :: iret integer :: ios ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if( present(iret)) iret=-6 if ( jrec.gt.0 .or. jrec.le.gfile%nrec) then name=gfile%recname(jrec) levtyp=gfile%reclevtyp(jrec) lev=gfile%reclev(jrec) if(present(iret)) iret=0 return else if ( present(iret)) then return else call nemsio_stop endif endif end subroutine nemsio_getrechead !------------------------------------------------------------------------------ subroutine nemsio_gfinit(gfile,iret,recname,reclevtyp,reclev) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: set gfile variables to operational model output !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none type(nemsio_gfile),intent(inout) :: gfile integer(nemsio_intkind),intent(out) :: iret character(nemsio_charkind),optional,intent(in) :: recname(:) character(nemsio_charkind*2),optional,intent(in):: reclevtyp(:) integer(nemsio_intkind),optional,intent(in) :: reclev(:) integer :: i,j,rec,rec3dopt real(nemsio_dblekind),allocatable :: slat(:),wlat(:) real(nemsio_dblekind),allocatable :: dx(:) real(nemsio_dblekind) :: radi logical ::linit ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! set operational format ! iret=-8 gfile%version=200809 gfile%nfday=0 gfile%nfhour=0 gfile%nfminute=0 gfile%nfsecondn=0 gfile%nfsecondd=100 gfile%extrameta=.false. gfile%nmetavari=0 gfile%nmetavarr=0 gfile%nmetavarl=0 gfile%nmetavarc=0 gfile%nmetaaryi=0 gfile%nmetaaryr=0 gfile%nmetaaryl=0 gfile%nmetaaryc=0 ! iret=0 end subroutine nemsio_gfinit !------------------------------------------------------------------------------ subroutine nemsio_stop(message) implicit none character(*),optional,intent(in) :: message integer ::ios !--- if ( present(message) ) print *,'message' call mpi_finalize(ios) stop ! end subroutine nemsio_stop !------------------------------------------------------------------------------ ! subroutine nemsio_denseread4(gfile,ista,iend,jsta,jend,data,iret) !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - ! abstract: free unit number array index corresponding to unit number !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - implicit none ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - type(nemsio_gfile),intent(inout) :: gfile integer,intent(in) :: ista,iend,jsta,jend real(nemsio_realkind),intent(out) :: data(:) integer,optional,intent(out) :: iret !--- local vars integer :: status(MPI_STATUS_SIZE) integer :: fieldmapsize,nfld,nfldloop,mfldrmd integer,allocatable :: fieldmap(:) integer ios,i,j,nfldsize,fieldmapsize1,k,nstt,nend integer(8) idispstt real(nemsio_dblekind),allocatable :: tmp(:) !--- iret=-25 ! if(size(data)/=(iend-ista+1)*(jend-jsta+1)*gfile%nrec) then print *,'WRONG: data size ',size(data),' doesn"t match total subdomain data size', & (iend-ista+1)*(jend-jsta+1)*gfile%nrec return endif !--- set nfld if(gfile%gdatatype(1:4).eq.'bin4') then nfldsize=gfile%fieldsize+2 elseif (gfile%gdatatype(1:4).eq.'bin8') then nfldsize=gfile%fieldsize+1 endif nfld=min(gfile%nrec,nemsio_maxint/nfldsize) nfldloop=(gfile%nrec-1)/nfld+1 mfldrmd=mod(gfile%nrec,nfld) ! print *,'in dense read,nfld=',nfld,'nfldloop=',nfldloop, & ! 'mfldrmd=',mfldrmd !--- set file map fieldmapsize=(iend-ista+1)*(jend-jsta+1)*nfld allocate(fieldmap(fieldmapsize) ) call set_mpimap_read(gfile,ista,iend,jsta,jend,fieldmap,ios) if(ios.ne.0) return !--- do k=1,nfldloop ! if(k= 65 .and. ic1 < 91) ic1 = ic1+32 ic2 = ichar(str2(i:i)) if (ic2 >= 65 .and. ic2 < 91) ic2 = ic2+32 if(ic1/=ic2) then equal_str_nocase=.false. return endif end do equal_str_nocase=.true. ! !----------------------------------------------------------------------- ! end function equal_str_nocase ! !----------------------------------------------------------------------- ! subroutine chk_endianc(endian) ! implicit none ! character(16),intent(out) :: endian ! ------------------------------------------------------------------ INTEGER,PARAMETER :: ASCII_0 = 48,ASCII_1 = 49,ASCII_2 = 50, & ASCII_3 = 51 INTEGER(4) :: I common// I ! ------------------------------------------------------------------ !***** code start ! ------------------------------------------------------------------ I = ASCII_0 + ASCII_1*256 + ASCII_2*(256**2) + ASCII_3*(256**3) call sub(endian) ! ! ------------------------------------------------------------------ ! end subroutine chk_endianc ! !----------------------------------------------------------------------- ! subroutine sub(endian) ! implicit none ! character(16),intent(out) :: endian ! character,intent(inout) :: i*4 character :: i*4 common// i ! ------------------------------------------------------------------ if(i .eq. '0123') then ! WRITE(*,*) ' Machine is Little-Endian ' endian='little_endian' return elseif (i .eq. '3210') then ! WRITE(*,*) ' Machine is Big-Endian ' endian='big_endian' return else ! WRITE(*,*) ' Mixed endianity machine ... ' endian='mixed_endian' return endif ! ! ------------------------------------------------------------------ ! end subroutine sub ! !------------------------------------------------------------------------------ end module nemsio_module_mpi