NCEPLIBS-nemsio  2.5.3
•All Data Structures Files
nemsio_module_mpi.f90
Go to the documentation of this file.
1 
82 
83 !!!--- file handler
84 !! - gfname: character(255) file name
85 !! - gaction: character(nemsio_charkind) read/write
86 !! - flunit: integer(nemsio_intkind) unit number
87 !!
88 !! Public method
89 !! - nemsio_init
90 !! - nemsio_finalize
91 !! - nemsio_open
92 !! - nemsio_writerec
93 !! - nemsio_readirec
94 !! - nemsio_writerecv
95 !! - nemsio_readirecv
96 !! - nemsio_writerecw34
97 !! - nemsio_readirecw34
98 !! - nemsio_writerecvw34
99 !! - nemsio_readirecvw34
100 !! - nemsio_close
101 !! - nemsio_getfilehead
102 !! Possible return code
103 !! - 0 Successful call
104 !! - -1 Open or close I/O error
105 !! - -2 array size
106 !! - -3 Meta data I/O error (possible EOF)
107 !! - -4 GETGB/PUTGB error
108 !! - -5 Search record and set GRIB message info error
109 !! - -6 allocate/deallocate error
110 !! - -7 set grib table
111 !! - -8 file meta data initialization (default:1152*576)
112 !! - -9 NOT nemsio type file
113 !! - -10 get/close file unit
114 !! - -11 read/write bin data
115 !! - -12 read/write NMM B grid lat lon
116 !! - -13 read/write NMM sfc var
117 !! - -15 read/write gsi
118 !! - -17 get var from file header
119 !! - -20 nemsio init
120 !!
121 module nemsio_module_mpi
122 !
123  use mpi
124 !
125  implicit none
126  private
127 !------------------------------------------------------------------------------
128 ! private variables and type needed by nemsio_gfile
129  integer,parameter:: nemsio_lmeta1=48,nemsio_lmeta3=40
130  integer,parameter:: nemsio_intkind=4,nemsio_intkind8=8
131  integer,parameter:: nemsio_realkind=4,nemsio_dblekind=8
132  integer,parameter:: nemsio_charkind=16,nemsio_charkind8=8, nemsio_charkind4=4
133  integer,parameter:: nemsio_logickind=4
134  integer,parameter:: nemsio_maxint=2147483647
135  real(nemsio_intkind),parameter :: nemsio_intfill=-9999_nemsio_intkind
136  integer(nemsio_intkind8),parameter :: nemsio_intfill8=-9999_nemsio_intkind8
137  logical(nemsio_logickind),parameter:: nemsio_logicfill=.false.
138  real(nemsio_intkind),parameter :: nemsio_kpds_intfill=-1_nemsio_intkind
139  real(nemsio_realkind),parameter :: nemsio_realfill=-9999._nemsio_realkind
140  real(nemsio_dblekind),parameter :: nemsio_dblefill=-9999._nemsio_dblekind
141 !
142 !------------------------------------------------------------------------------
143 !--- public types
144  type,public :: nemsio_gfile
145  private
146  character(nemsio_charkind8) :: gtype=' '
147  integer(nemsio_intkind):: version=nemsio_intfill
148  character(nemsio_charkind8):: gdatatype=' '
149  character(nemsio_charkind8):: modelname=' '
150  integer(nemsio_intkind):: nmeta=nemsio_intfill
151  integer(nemsio_intkind):: lmeta=nemsio_intfill
152  integer(nemsio_intkind):: nrec=nemsio_intfill
153 !
154  integer(nemsio_intkind):: idate(7)=nemsio_intfill
155  integer(nemsio_intkind):: nfday=nemsio_intfill
156  integer(nemsio_intkind):: nfhour=nemsio_intfill
157  integer(nemsio_intkind):: nfminute=nemsio_intfill
158  integer(nemsio_intkind):: nfsecondn=nemsio_intfill
159  integer(nemsio_intkind):: nfsecondd=nemsio_intfill
160 ! integer(nemsio_intkind):: ifdate(7)=nemsio_intfill
161 !
162  integer(nemsio_intkind):: dimx=nemsio_intfill
163  integer(nemsio_intkind):: dimy=nemsio_intfill
164  integer(nemsio_intkind):: dimz=nemsio_intfill
165  integer(nemsio_intkind):: nframe=nemsio_intfill
166  integer(nemsio_intkind):: nsoil=nemsio_intfill
167  integer(nemsio_intkind):: ntrac=nemsio_intfill
168 !
169  integer(nemsio_intkind) :: jcap=nemsio_intfill
170  integer(nemsio_intkind) :: ncldt=nemsio_intfill
171  integer(nemsio_intkind) :: idvc=nemsio_intfill
172  integer(nemsio_intkind) :: idsl=nemsio_intfill
173  integer(nemsio_intkind) :: idvm=nemsio_intfill
174  integer(nemsio_intkind) :: idrt=nemsio_intfill
175  real(nemsio_realkind) :: rlon_min=nemsio_realfill
176  real(nemsio_realkind) :: rlon_max=nemsio_realfill
177  real(nemsio_realkind) :: rlat_min=nemsio_realfill
178  real(nemsio_realkind) :: rlat_max=nemsio_realfill
179  logical(nemsio_logickind) :: extrameta=nemsio_logicfill
180 !
181  integer(nemsio_intkind):: nmetavari=nemsio_intfill
182  integer(nemsio_intkind):: nmetavarr=nemsio_intfill
183  integer(nemsio_intkind):: nmetavarl=nemsio_intfill
184  integer(nemsio_intkind):: nmetavarc=nemsio_intfill
185  integer(nemsio_intkind):: nmetavarr8=nemsio_intfill
186  integer(nemsio_intkind):: nmetaaryi=nemsio_intfill
187  integer(nemsio_intkind):: nmetaaryr=nemsio_intfill
188  integer(nemsio_intkind):: nmetaaryl=nemsio_intfill
189  integer(nemsio_intkind):: nmetaaryc=nemsio_intfill
190  integer(nemsio_intkind):: nmetaaryr8=nemsio_intfill
191 !
192  character(nemsio_charkind),allocatable :: recname(:)
193  character(nemsio_charkind),allocatable :: reclevtyp(:)
194  integer(nemsio_intkind),allocatable :: reclev(:)
195 !
196  real(nemsio_realkind),allocatable :: vcoord(:,:,:)
197  real(nemsio_realkind),allocatable :: lat(:)
198  real(nemsio_realkind),allocatable :: lon(:)
199  real(nemsio_realkind),allocatable :: dx(:)
200  real(nemsio_realkind),allocatable :: dy(:)
201 !
202  real(nemsio_realkind),allocatable :: Cpi(:)
203  real(nemsio_realkind),allocatable :: Ri(:)
204 !
205  character(nemsio_charkind),allocatable :: variname(:)
206  integer(nemsio_intkind),allocatable :: varival(:)
207  character(nemsio_charkind),allocatable :: varrname(:)
208  real(nemsio_realkind),allocatable :: varrval(:)
209  character(nemsio_charkind),allocatable :: varr8name(:)
210  real(nemsio_dblekind),allocatable :: varr8val(:)
211  character(nemsio_charkind),allocatable :: varlname(:)
212  logical(nemsio_logickind),allocatable :: varlval(:)
213  character(nemsio_charkind),allocatable :: varcname(:)
214  character(nemsio_charkind),allocatable :: varcval(:)
215 !
216  character(nemsio_charkind),allocatable :: aryiname(:)
217  integer(nemsio_intkind),allocatable :: aryilen(:)
218  integer(nemsio_intkind),allocatable :: aryival(:,:)
219  character(nemsio_charkind),allocatable :: aryrname(:)
220  integer(nemsio_intkind),allocatable :: aryrlen(:)
221  real(nemsio_realkind),allocatable :: aryrval(:,:)
222  character(nemsio_charkind),allocatable :: arylname(:)
223  integer(nemsio_intkind),allocatable :: aryllen(:)
224  logical(nemsio_logickind),allocatable :: arylval(:,:)
225  character(nemsio_charkind),allocatable :: arycname(:)
226  integer(nemsio_intkind),allocatable :: aryclen(:)
227  character(nemsio_charkind),allocatable :: arycval(:,:)
228  character(nemsio_charkind),allocatable :: aryr8name(:)
229  integer(nemsio_intkind),allocatable :: aryr8len(:)
230  real(nemsio_dblekind),allocatable :: aryr8val(:,:)
231 !
232  character(255) :: gfname
233  character(nemsio_charkind8) :: gaction
234  integer(nemsio_intkind8) :: tlmeta=nemsio_intfill
235  integer(nemsio_intkind) :: fieldsize=nemsio_intfill
236  integer(nemsio_intkind) :: flunit=nemsio_intfill
237  integer(nemsio_intkind) :: headvarinum=nemsio_intfill
238  integer(nemsio_intkind) :: headvarrnum=nemsio_intfill
239  integer(nemsio_intkind) :: headvarcnum=nemsio_intfill
240  integer(nemsio_intkind) :: headvarlnum=nemsio_intfill
241  integer(nemsio_intkind) :: headaryinum=nemsio_intfill
242  integer(nemsio_intkind) :: headaryrnum=nemsio_intfill
243  integer(nemsio_intkind) :: headarycnum=nemsio_intfill
244  character(nemsio_charkind),allocatable :: headvarcname(:)
245  character(nemsio_charkind),allocatable :: headvariname(:)
246  character(nemsio_charkind),allocatable :: headvarrname(:)
247  character(nemsio_charkind),allocatable :: headvarlname(:)
248  character(nemsio_charkind),allocatable :: headaryiname(:)
249  character(nemsio_charkind),allocatable :: headaryrname(:)
250  character(nemsio_charkind),allocatable :: headarycname(:)
251  integer(nemsio_intkind),allocatable :: headvarival(:)
252  real(nemsio_realkind),allocatable :: headvarrval(:)
253  character(nemsio_charkind),allocatable :: headvarcval(:)
254  logical(nemsio_logickind),allocatable :: headvarlval(:)
255  integer(nemsio_intkind),allocatable :: headaryival(:,:)
256  real(nemsio_realkind),allocatable :: headaryrval(:,:)
257  character(nemsio_charkind),allocatable :: headarycval(:,:)
258  character,allocatable :: cbuf(:)
259  integer(nemsio_intkind):: mbuf=0,nlen,nnum,mnum
260  integer(nemsio_intkind8) :: tlmetalat=nemsio_intfill
261  integer(nemsio_intkind8) :: tlmetalon=nemsio_intfill
262  integer(nemsio_intkind8) :: tlmetadx=nemsio_intfill
263  integer(nemsio_intkind8) :: tlmetady=nemsio_intfill
264  integer(nemsio_intkind8) :: tlmetavarival=nemsio_intfill
265  integer(nemsio_intkind8) :: tlmetaaryival=nemsio_intfill
266  character(16) :: file_endian=''
267  logical :: do_byteswap=.false.
268 !-- for MPI I/O
269  integer(nemsio_intkind) :: mpi_comm=nemsio_intfill
270  integer(nemsio_intkind) :: lead_task=nemsio_intfill
271  integer(nemsio_intkind) :: mype=nemsio_intfill
272  integer(nemsio_intkind) :: npes=nemsio_intfill
273  integer(nemsio_intkind) :: fh=nemsio_intfill
274  real(nemsio_realkind) :: fieldsize_real4=nemsio_realfill
275  real(nemsio_dblekind) :: fieldsize_real8=nemsio_realfill
276  end type nemsio_gfile
277 !
278 !------------------------------------------------------------------------------
279 !--- private types
280 !
281  type :: nemsio_meta1
282  sequence
283  character(nemsio_charkind8) :: gtype
284  character(nemsio_charkind8) :: modelname
285  character(nemsio_charkind8) :: gdatatype
286  integer(nemsio_intkind) :: version,nmeta,lmeta
287  integer(nemsio_intkind) :: reserve(3)
288  end type nemsio_meta1
289 !
290  type :: nemsio_meta2
291  sequence
292  integer(nemsio_intkind) :: nrec
293  integer(nemsio_intkind) :: idate(1:7),nfday,nfhour,nfminute,nfsecondn, &
294  nfsecondd,dimx,dimy,dimz,nframe,nsoil,ntrac,&
295  jcap,ncldt,idvc,idsl,idvm,idrt
296  real(nemsio_realkind) :: rlon_min,rlon_max,rlat_min,rlat_max
297  logical(nemsio_logickind) :: extrameta
298  end type nemsio_meta2
299 !
300  type :: nemsio_meta3
301  integer(nemsio_intkind) :: nmetavari,nmetavarr,nmetavarl,nmetavarc, &
302  nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc, &
303  nmetavarr8,nmetaaryr8
304  end type nemsio_meta3
305 !
306  character(16) :: machine_endian='big_endian'
307 !
308 !*** for mpi
309  integer(nemsio_intkind) :: itypemeta1,itypemeta2
310 !
311  type :: nemsio_grbmeta
312  integer(nemsio_intkind) :: jf=nemsio_intfill
313  integer(nemsio_intkind) :: j=nemsio_kpds_intfill
314  logical*1,allocatable :: lbms(:)
315  integer(nemsio_intkind) :: jpds(200)=nemsio_kpds_intfill
316  integer(nemsio_intkind) :: jgds(200)=nemsio_kpds_intfill
317  end type nemsio_grbmeta
318 !
319 !----- interface
320  interface nemsio_getheadvar
321  module procedure nemsio_getfheadvari
322  module procedure nemsio_getfheadvarr
323  module procedure nemsio_getfheadvarl
324  module procedure nemsio_getfheadvarc
325  module procedure nemsio_getfheadvarr8
326  module procedure nemsio_getfheadaryi
327  module procedure nemsio_getfheadaryr
328  module procedure nemsio_getfheadaryr8
329  module procedure nemsio_getfheadaryl
330  module procedure nemsio_getfheadaryc
331  end interface nemsio_getheadvar
332 !
333  interface nemsio_denseread
334  module procedure nemsio_denseread4
335  module procedure nemsio_denseread8
336  end interface nemsio_denseread
337 !
338  interface nemsio_densewrite
339  module procedure nemsio_densewrite4
340  module procedure nemsio_densewrite8
341  end interface nemsio_densewrite
342 !
343 !--- file unit for putgb/getgb ----
344  integer(nemsio_intkind),save :: fileunit(600:699)=0
345 !------------------------------------------------------------------------------
346 !public mehtods
347  public nemsio_intkind,nemsio_intkind8,nemsio_realkind,nemsio_dblekind
348  public nemsio_charkind,nemsio_charkind8,nemsio_logickind
349  public nemsio_init,nemsio_finalize,nemsio_open,nemsio_close
350  public nemsio_denseread,nemsio_densewrite
351  public nemsio_getfilehead,nemsio_getheadvar,nemsio_getrechead
352 !
353 contains
354 !-------------------------------------------------------------------------------
355  subroutine nemsio_init(iret)
356 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
357 ! initialization
358 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
359  implicit none
360  integer(nemsio_intkind),optional,intent(out):: iret
361 !-- local vars
362  integer :: meta1_type(2),meta1_block(2),meta1_disp(2)
363  integer :: meta2_type(3),meta2_block(3),meta2_disp(3)
364  integer :: ios
365 !
366  if (present(iret))iret=1
367 !------------------------------------------------------------
368 ! MPI set meta data type
369 !------------------------------------------------------------
370 ! 1. meta1
371  meta1_type(1)=mpi_character
372  meta1_type(2)=mpi_integer
373  meta1_block(1)=24
374  meta1_block(2)=6
375  meta1_disp(1)=0
376  meta1_disp(2)=meta1_disp(1)+meta1_block(1)*1
377  call mpi_type_struct(2,meta1_block,meta1_disp,meta1_type, &
378  itypemeta1,ios)
379  call mpi_type_commit(itypemeta1,ios)
380  if ( ios.ne.0 ) then
381  return
382  endif
383 !
384 ! 2. meta2
385  meta2_type(1)=mpi_integer
386  meta2_type(2)=mpi_real
387  meta2_type(3)=mpi_logical
388  meta2_block(1)=25
389  meta2_block(2)=4
390  meta2_block(3)=1
391  meta2_disp(1)=0
392  meta2_disp(2)=meta2_block(1)*4+meta2_disp(1)
393  meta2_disp(3)=meta2_block(2)*4+meta2_disp(2)
394  call mpi_type_struct(3,meta2_block,meta2_disp,meta2_type, &
395  itypemeta2,ios)
396  call mpi_type_commit(itypemeta2,ios)
397  if ( ios.ne.0 ) then
398  return
399  endif
400 !
401 !------------------------------------------------------------
402 ! check machine endian
403 !------------------------------------------------------------
404  call chk_endianc(machine_endian)
405  if(trim(machine_endian)=='mixed_endian') then
406  call nemsio_stop('You are in mixed endian computer,stop!!!')
407  endif
408 !
409  if(present(iret)) iret=0
410 !
411  end subroutine nemsio_init
412 !------------------------------------------------------------------------------
413  subroutine nemsio_finalize()
414 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
415 ! abstract: finalization
416 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
417  implicit none
418 !--
419  end subroutine nemsio_finalize
420 !------------------------------------------------------------------------------
421  subroutine nemsio_open(gfile,gfname,gaction,mpi_comm, &
422  iret,gdatatype,version,mype,npes, &
423  nmeta,lmeta,modelname,nrec,idate,nfday,nfhour,nfminute,nfsecondn, &
424  nfsecondd, &
425  dimx,dimy,dimz,nframe,nsoil,ntrac,jcap,ncldt,idvc,idsl,idvm,idrt, &
426  rlon_min,rlon_max,rlat_min,rlat_max,extrameta, &
427  nmetavari,nmetavarr,nmetavarl,nmetavarc, &
428  nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc, &
429  nmetavarr8,nmetaaryr8, &
430  recname,reclevtyp,reclev,vcoord,lat,lon,dx,dy,cpi,ri, &
431  variname,varival,varrname,varrval,varlname,varlval,varcname,varcval, &
432  varr8name,varr8val, &
433  aryiname,aryilen,aryival,aryrname,aryrlen,aryrval, &
434  arylname,aryllen,arylval,arycname,aryclen,arycval, &
435  aryr8name,aryr8len,aryr8val )
436 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
437 ! abstract: open nemsio file, and read/write the meta data
438 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
439  implicit none
440  type(nemsio_gfile),intent(inout) :: gfile
441  character*(*),intent(in) :: gfname
442  character*(*),intent(in) :: gaction
443  integer,intent(in) :: mpi_comm
444 !-------------------------------------------------------------------------------
445 ! optional variables
446 !-------------------------------------------------------------------------------
447  integer(nemsio_intkind),optional,intent(out) :: iret
448  character*(*),optional,intent(in) :: gdatatype,modelname
449  integer(nemsio_intkind),optional,intent(in) :: version,nmeta,lmeta,nrec
450  integer,optional,intent(in) :: mype,npes
451  integer(nemsio_intkind),optional,intent(in) :: idate(7),nfday,nfhour, &
452  nfminute, nfsecondn,nfsecondd
453  integer(nemsio_logickind),optional,intent(in):: dimx,dimy,dimz,nframe, &
454  nsoil,ntrac
455  integer(nemsio_logickind),optional,intent(in):: jcap,ncldt,idvc,idsl, &
456  idvm,idrt
457  real(nemsio_realkind),optional,intent(in) :: rlat_min,rlat_max, &
458  rlon_min,rlon_max
459  logical(nemsio_logickind),optional,intent(in):: extrameta
460  integer(nemsio_intkind),optional,intent(in) :: nmetavari,nmetavarr, &
461  nmetavarl,nmetavarc,nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc, &
462  nmetavarr8,nmetaaryr8
463 !
464  character*(*),optional,intent(in) :: recname(:),reclevtyp(:)
465  integer(nemsio_intkind),optional,intent(in) :: reclev(:)
466  real(nemsio_realkind),optional,intent(in) :: vcoord(:,:,:)
467  real(nemsio_realkind),optional,intent(in) :: lat(:),lon(:)
468  real(nemsio_realkind),optional,intent(in) :: dx(:),dy(:)
469  real(nemsio_realkind),optional,intent(in) :: Cpi(:),Ri(:)
470 !
471  character*(*),optional,intent(in) :: variname(:),varrname(:),&
472  varlname(:),varcname(:),varr8name(:),aryiname(:),aryrname(:), &
473  arylname(:),arycname(:),aryr8name(:)
474  integer(nemsio_intkind),optional,intent(in) :: aryilen(:),aryrlen(:), &
475  aryllen(:),aryclen(:),aryr8len(:)
476  integer(nemsio_intkind),optional,intent(in) :: varival(:),aryival(:,:)
477  real(nemsio_realkind),optional,intent(in) :: varrval(:),aryrval(:,:)
478  real(nemsio_dblekind),optional,intent(in) :: varr8val(:),aryr8val(:,:)
479  logical(nemsio_logickind),optional,intent(in):: varlval(:),arylval(:,:)
480  character(*),optional,intent(in) :: varcval(:),arycval(:,:)
481 !
482  integer :: ios
483 !------------------------------------------------------------
484 !### for MPI IO, just need this part for read header ######
485 ! assign a unit number
486 !------------------------------------------------------------
487  if (present(iret)) iret=-1
488 !
489  gfile%gfname=gfname
490  gfile%gaction=gaction
491  gfile%mpi_comm=mpi_comm
492  gfile%lead_task=0
493 !
494  if(present(mype)) then
495  gfile%mype=mype
496  else
497  call mpi_comm_rank(mpi_comm,gfile%mype,ios)
498  if ( ios.ne.0 ) then
499  if ( present(iret)) then
500  iret=ios
501  return
502  else
503  call nemsio_stop
504  endif
505  endif
506  endif
507  if(present(npes)) then
508  gfile%npes=npes
509  else
510  call mpi_comm_size(mpi_comm,gfile%npes,ios)
511  if ( ios.ne.0 ) then
512  if ( present(iret)) then
513  iret=ios
514  return
515  else
516  call nemsio_stop
517  endif
518  endif
519  endif
520 !
521 !------------------------------------------------------------
522 ! open and read meta data for READ
523 !------------------------------------------------------------
524  if ( equal_str_nocase(trim(gaction),"read").or. &
525  equal_str_nocase(trim(gaction),"rdwr") )then
526 !
527 !-read 2D field using MPI I/O
528 !
529  if(equal_str_nocase(trim(gaction),"read")) then
530  call mpi_file_open(mpi_comm,gfname,mpi_mode_rdonly,mpi_info_null,gfile%fh,ios)
531  else if(equal_str_nocase(trim(gaction),"rdwt")) then
532  call mpi_file_open(mpi_comm,gfname,mpi_mode_rdwr,mpi_info_null,gfile%fh,ios)
533  endif
534  if ( ios.ne.0) then
535  if ( present(iret)) then
536  return
537  else
538  call nemsio_stop
539  endif
540  endif
541 !
542 !-read meta data for gfile, use non-mpi read for header
543 !
544  call nemsio_rcreate(gfile,ios)
545 ! write(0,*)'after nemsio_rcreate'
546  if ( ios.ne.0) then
547  if ( present(iret)) then
548  iret=ios
549  return
550  else
551  call nemsio_stop
552  endif
553  endif
554 !------------------------------------------------------------
555 ! open and write meta data for WRITE
556 !------------------------------------------------------------
557  elseif (equal_str_nocase(trim(gaction),"write")) then
558 !
559 !-write 2D field using MPI I/O
560 !
561  call mpi_file_open(mpi_comm,gfname,mpi_mode_create+mpi_mode_wronly, &
562  mpi_info_null,gfile%fh,ios)
563 ! print *,'mype=',gfile%mype,'after mpi_file_open,ios=',ios
564  if ( ios.ne.0) then
565  if ( present(iret)) then
566  return
567  else
568  call nemsio_stop
569  endif
570  endif
571 !
572 !-write meta data for gfile, use non-mpi write for header
573 !
574  call nemsio_wcreate(gfile,ios,gdatatype=gdatatype, &
575  version=version, nmeta=nmeta,lmeta=lmeta,modelname=modelname, &
576  nrec=nrec,idate=idate,nfday=nfday,nfhour=nfhour,nfminute=nfminute,&
577  nfsecondn=nfsecondn, nfsecondd=nfsecondd, &
578  dimx=dimx,dimy=dimy,dimz=dimz,nframe=nframe,nsoil=nsoil, &
579  ntrac=ntrac,jcap=jcap,ncldt=ncldt,idvc=idvc,idsl=idsl, &
580  idvm=idvm,idrt=idrt, &
581  rlon_min=rlon_min,rlon_max=rlon_max,rlat_min=rlat_min, &
582  rlat_max=rlat_max,extrameta=extrameta, &
583  nmetavari=nmetavari,nmetavarr=nmetavarr,nmetavarr8=nmetavarr8,&
584  nmetavarl=nmetavarl,nmetavarc=nmetavarc, &
585  nmetaaryi=nmetaaryi,nmetaaryr=nmetaaryr,nmetaaryr8=nmetaaryr8,&
586  nmetaaryl=nmetaaryl,nmetaaryc=nmetaaryc, &
587  recname=recname,reclevtyp=reclevtyp, &
588  reclev=reclev,vcoord=vcoord,lat=lat,lon=lon,dx=dx,dy=dy, &
589  cpi=cpi,ri=ri,variname=variname,varival=varival,varrname=varrname,&
590  varrval=varrval,varlname=varlname,varlval=varlval, &
591  varcname=varcname,varcval=varcval, &
592  varr8name=varr8name,varr8val=varr8val, &
593  aryiname=aryiname,aryilen=aryilen,aryival=aryival, &
594  aryrname=aryrname,aryrlen=aryrlen,aryrval=aryrval, &
595  aryr8name=aryr8name,aryr8len=aryr8len,aryr8val=aryr8val, &
596  arylname=arylname,aryllen=aryllen,arylval=arylval, &
597  arycname=arycname,aryclen=aryclen,arycval=arycval )
598  if ( ios.ne.0) then
599  if ( present(iret)) then
600  iret=ios
601  return
602  else
603  call nemsio_stop
604  endif
605  endif
606 !
607 !------------------------------------------------------------
608 ! if gaction is wrong
609 !------------------------------------------------------------
610  else
611  if ( present(iret)) then
612  return
613  else
614  call nemsio_stop
615  endif
616  endif
617 !------------------------------------------------------------
618 ! set default header
619 !------------------------------------------------------------
620  if(.not.allocated(gfile%headvariname).or. &
621  .not.allocated(gfile%headvarrname).or. &
622  .not.allocated(gfile%headvarcname).or. &
623  .not.allocated(gfile%headvarlname).or. &
624  .not.allocated(gfile%headaryiname).or. &
625  .not.allocated(gfile%headaryrname) ) then
626  call nemsio_setfhead(gfile,ios)
627  if ( present(iret)) iret=ios
628  if ( ios.ne.0) then
629  if (present(iret)) return
630  call nemsio_stop
631  endif
632  endif
633 !
634  iret=0
635 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
636  end subroutine nemsio_open
637 !-------------------------------------------------------------------------------
638  subroutine nemsio_close(gfile,iret)
639 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
640 ! abstract: close gfile including closing the file, returning unit number,
641 ! setting file meta data empty
642 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
643  implicit none
644  type(nemsio_gfile),intent(inout) :: gfile
645  integer(nemsio_intkind),optional,intent(out) :: iret
646  integer(nemsio_intkind) :: ios
647 !------------------------------------------------------------
648 ! close the file
649 !------------------------------------------------------------
650  if ( present(iret) ) iret=-1
651  call mpi_file_close(gfile%fh,ios)
652  if ( ios.ne.0) then
653  if ( present(iret)) then
654  return
655  else
656  call nemsio_stop
657  endif
658  endif
659 !------------------------------------------------------------
660 ! empty gfile meta data
661 !------------------------------------------------------------
662  call nemsio_axmeta(gfile,ios)
663  if ( ios.ne.0) then
664  if ( present(iret)) then
665  iret=ios
666  return
667  else
668  call nemsio_stop
669  endif
670  endif
671  if ( present(iret)) iret=0
672 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
673  end subroutine nemsio_close
674 !------------------------------------------------------------------------------
675  subroutine nemsio_rcreate(gfile,iret)
676 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
677 ! abstract: read nemsio meta data
678 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
679  implicit none
680  type(nemsio_gfile),intent(inout) :: gfile
681  integer(nemsio_intkind),intent(out) :: iret
682 !local variables
683  integer(nemsio_intkind) :: ios,nmeta,tlmeta4
684  integer(nemsio_intkind) :: iread
685  integer (kind=mpi_offset_kind) ::idisp
686  integer :: status(mpi_status_size)
687  type(nemsio_meta1) :: meta1
688  type(nemsio_meta2) :: meta2
689  type(nemsio_meta3) :: meta3
690  integer(nemsio_intkind) :: i,nummeta
691  character(nemsio_charkind8),allocatable :: char8var(:)
692 !------------------------------------------------------------
693 ! open gfile for read header
694 !------------------------------------------------------------
695  iret=-3
696 !------------------------------------------------------------
697 ! read first meta data record
698 !------------------------------------------------------------
699  idisp=4
700  call mpi_file_read_at(gfile%fh,idisp,meta1,1,itypemeta1,status,ios)
701 ! print *,'1 PE',gfile%mype,'ios=',ios,' gtype=',meta1%gtype, meta1%modelname, &
702 ! meta1%gdatatype,meta1%version,meta1%nmeta,meta1%lmeta
703 !
704  gfile%do_byteswap=.false.
705 ! check byteswap
706  if(meta1%lmeta/=120) then
707  gfile%do_byteswap=.true.
708  if(gfile%do_byteswap) call byteswap(meta1%version,nemsio_intkind,6)
709  endif
710  gfile%gtype=meta1%gtype
711  gfile%gdatatype=meta1%gdatatype
712  gfile%modelname=meta1%modelname
713  gfile%version=meta1%version
714  gfile%nmeta=meta1%nmeta
715  gfile%lmeta=meta1%lmeta
716  gfile%tlmeta=nemsio_lmeta1+8
717  if ( trim(gfile%gdatatype(1:3)).ne."bin" &
718  .and. trim(gfile%gdatatype(1:4)).ne."grib" ) then
719  gfile%gdatatype="grib"
720  endif
721 ! print *,'aft meta1,gtype=',trim(gfile%gtype),'version=',gfile%version, &
722 ! 'nmeta=',gfile%nmeta,'gfile%lmeta=',gfile%lmeta,'gfile%gdatatype=', &
723 ! gfile%gdatatype,'modelname=',gfile%modelname
724  if ( gfile%gtype(1:6) .ne. 'NEMSIO' ) then
725  iret=-9
726  return
727  endif
728 !------------------------------------------------------------
729 ! read second meta data record
730 !------------------------------------------------------------
731  idisp=gfile%tlmeta+4
732  call mpi_file_read_at(gfile%fh,idisp,meta2,1,itypemeta2,status,ios)
733  if(gfile%do_byteswap) then
734  call byteswap(meta2%nrec,nemsio_intkind,25)
735  call byteswap(meta2%rlon_min,nemsio_realkind,4)
736  call byteswap(meta2%extrameta,nemsio_logickind,1)
737  endif
738  gfile%tlmeta=gfile%tlmeta+nemsio_intkind*25+nemsio_realkind*4+nemsio_logickind+8
739 !
740  gfile%nrec=meta2%nrec
741  gfile%idate(1:7)=meta2%idate(1:7)
742  gfile%nfday=meta2%nfday
743  gfile%nfhour=meta2%nfhour
744  gfile%nfminute=meta2%nfminute
745  gfile%nfsecondn=meta2%nfsecondn
746  gfile%nfsecondd=meta2%nfsecondd
747  gfile%dimx=meta2%dimx
748  gfile%dimy=meta2%dimy
749  gfile%dimz=meta2%dimz
750  gfile%nframe=meta2%nframe
751  gfile%nsoil=meta2%nsoil
752  gfile%ntrac=meta2%ntrac
753  gfile%jcap=meta2%jcap
754  gfile%ncldt=meta2%ncldt
755  gfile%idvc=meta2%idvc
756  gfile%idsl=meta2%idsl
757  gfile%idvm=meta2%idvm
758  gfile%idrt=meta2%idrt
759  gfile%rlon_min=meta2%rlon_min
760  gfile%rlon_max=meta2%rlon_max
761  gfile%rlat_min=meta2%rlat_min
762  gfile%rlat_max=meta2%rlat_max
763  gfile%extrameta=meta2%extrameta
764  gfile%fieldsize=(gfile%dimx+2*gfile%nframe)*(gfile%dimy+2*gfile%nframe)
765 ! print *,'meta2,nrec=',gfile%nrec,gfile%idate(1:7),gfile%nfday, &
766 ! gfile%nfhour,gfile%nfminute,gfile%nfsecondn,gfile%nfsecondd, &
767 ! gfile%dimx,gfile%dimy,gfile%dimz,gfile%nframe,gfile%nsoil, &
768 ! gfile%ntrac,gfile%jcap,gfile%ncldt,gfile%idvc,gfile%idsl, &
769 ! gfile%idvm,gfile%idrt,gfile%rlon_min,gfile%rlon_max, &
770 ! gfile%rlat_min,gfile%rlat_max,gfile%extrameta
771 
772  nummeta=gfile%nmeta
773 !------------------------------------------------------------
774 ! set up gfile required meata arrays
775 !------------------------------------------------------------
776  call nemsio_almeta(gfile,ios)
777  if ( ios .ne. 0 ) then
778  iret=ios
779  return
780  endif
781 !------------------------------------------------------------
782 ! read gfile meta data array (meta rec 3:13)
783 !------------------------------------------------------------
784 !meta3:recname
785  if(nummeta>2) then
786  idisp=gfile%tlmeta+4
787  iread=len(gfile%recname)*size(gfile%recname)
788  call mpi_file_read_at(gfile%fh,idisp,gfile%recname,iread,mpi_character,status,ios)
789  nmeta=nmeta-1
790  gfile%tlmeta=gfile%tlmeta+iread+8
791  endif
792 !meta4:reclevtyp
793  if(nummeta>3) then
794  idisp=gfile%tlmeta+4
795  call mpi_file_read_at(gfile%fh,idisp,gfile%reclevtyp,iread,mpi_character,status,ios)
796  nmeta=nmeta-1
797  gfile%tlmeta=gfile%tlmeta+iread+8
798  endif
799 !meta5:reclev
800  if(nummeta>4) then
801  idisp=gfile%tlmeta+4
802  iread=size(gfile%reclev)
803  call mpi_file_read_at(gfile%fh,idisp,gfile%reclev,iread,mpi_integer,status,ios)
804  if(gfile%do_byteswap) call byteswap(gfile%reclev,nemsio_intkind,size(gfile%reclev))
805  nmeta=nmeta-1
806  gfile%tlmeta=gfile%tlmeta+kind(gfile%reclev)*iread+8
807  endif
808 !meta6:vcoord
809  if(nummeta>5) then
810  idisp=gfile%tlmeta+4
811  iread=size(gfile%vcoord)
812  call mpi_file_read_at(gfile%fh,idisp,gfile%vcoord,iread,mpi_real,status,ios)
813  if(gfile%do_byteswap) call byteswap(gfile%vcoord,nemsio_realkind,size(gfile%vcoord))
814  nmeta=nmeta-1
815  gfile%tlmeta=gfile%tlmeta+kind(gfile%vcoord)*iread+8
816  endif
817 !meta7:lat
818  if(nummeta>6) then
819  idisp=gfile%tlmeta+4
820  iread=size(gfile%lat)
821  call mpi_file_read_at(gfile%fh,idisp,gfile%lat,iread,mpi_real,status,ios)
822  if(gfile%do_byteswap) call byteswap(gfile%lat,nemsio_realkind,size(gfile%lat))
823  nmeta=nmeta-1
824  gfile%tlmeta=gfile%tlmeta+kind(gfile%lat)*iread+8
825  endif
826 !meta8:lon
827  if(nummeta>7) then
828  idisp=gfile%tlmeta+4
829  call mpi_file_read_at(gfile%fh,idisp,gfile%lon,iread,mpi_real,status,ios)
830  if(gfile%do_byteswap) call byteswap(gfile%lon,nemsio_realkind,size(gfile%lon))
831  nmeta=nmeta-1
832  gfile%tlmeta=gfile%tlmeta+kind(gfile%lon)*iread+8
833  endif
834 !meta9:dx
835  if(nummeta>8) then
836  idisp=gfile%tlmeta+4
837  call mpi_file_read_at(gfile%fh,idisp,gfile%dx,iread,mpi_real,status,ios)
838  if(gfile%do_byteswap) call byteswap(gfile%dx,nemsio_realkind,size(gfile%dx))
839  nmeta=nmeta-1
840  gfile%tlmeta=gfile%tlmeta+kind(gfile%dx)*iread+8
841  endif
842 !meta10:dy
843  if(nummeta>9) then
844  idisp=gfile%tlmeta+4
845  call mpi_file_read_at(gfile%fh,idisp,gfile%dy,iread,mpi_real,status,ios)
846  if(gfile%do_byteswap) call byteswap(gfile%dy,nemsio_realkind,size(gfile%dy))
847  nmeta=nmeta-1
848  gfile%tlmeta=gfile%tlmeta+kind(gfile%dy)*iread+8
849  endif
850 !meta11:cpi
851  if(nummeta>10) then
852  idisp=gfile%tlmeta+4
853  iread=size(gfile%cpi)
854  call mpi_file_read_at(gfile%fh,idisp,gfile%cpi,iread,mpi_real,status,ios)
855  if(gfile%do_byteswap) call byteswap(gfile%cpi,nemsio_realkind,size(gfile%cpi))
856  nmeta=nmeta-1
857  gfile%tlmeta=gfile%tlmeta+kind(gfile%cpi)*iread+8
858  endif
859 !Ri
860  if(nummeta>11) then
861  idisp=gfile%tlmeta+4
862  call mpi_file_read_at(gfile%fh,idisp,gfile%ri,iread,mpi_real,status,ios)
863  if(gfile%do_byteswap) call byteswap(gfile%ri,nemsio_realkind,size(gfile%ri))
864  nmeta=nmeta-1
865  gfile%tlmeta=gfile%tlmeta+kind(gfile%ri)*iread+8
866  endif
867 !
868  extrameta_if: if(gfile%extrameta) then
869 !------------------------------------------------------------
870 ! read out extra meta data
871 !------------------------------------------------------------
872  idisp=gfile%tlmeta
873  call mpi_file_read_at(gfile%fh,idisp,iread,1,mpi_integer,status,ios)
874  if(gfile%do_byteswap) call byteswap(iread,nemsio_intkind,1)
875  idisp=gfile%tlmeta+4
876  if(iread/4==10) then
877  call mpi_file_read_at(gfile%fh,idisp,meta3,10,mpi_integer,status,ios)
878  if(gfile%do_byteswap) call byteswap(meta3,nemsio_intkind,10)
879  gfile%nmetavarr8=meta3%nmetavarr8
880  gfile%nmetaaryr8=meta3%nmetaaryr8
881  gfile%tlmeta=gfile%tlmeta+nemsio_lmeta3+8
882  elseif(iread/4==8) then
883  call mpi_file_read_at(gfile%fh,idisp,meta3,8,mpi_integer,status,ios)
884  if(gfile%do_byteswap) call byteswap(meta3,nemsio_intkind,8)
885  gfile%tlmeta=gfile%tlmeta+nemsio_lmeta3
886  endif
887  gfile%nmetavari=meta3%nmetavari
888  gfile%nmetavarr=meta3%nmetavarr
889  gfile%nmetavarl=meta3%nmetavarl
890  gfile%nmetavarc=meta3%nmetavarc
891  gfile%nmetaaryi=meta3%nmetaaryi
892  gfile%nmetaaryr=meta3%nmetaaryr
893  gfile%nmetaaryl=meta3%nmetaaryl
894  gfile%nmetaaryc=meta3%nmetaaryc
895 !
896 ! print *,'after meta3,nmetavari=',gfile%nmetavari,'nvarr=',gfile%nmetavarr, &
897 ! 'varl=',gfile%nmetavarl,'varc=',gfile%nmetavarc, gfile%nmetavarr8,'naryi=',&
898 ! gfile%nmetaaryi,gfile%nmetaaryr,gfile%nmetaaryl,gfile%nmetaaryc,gfile%nmetaaryr8,&
899 ! 'iread=',iread
900 
901  call nemsio_alextrameta(gfile,ios)
902  if ( ios .ne. 0 ) then
903  iret=ios
904  return
905  endif
906 
907 !meta var integer
908  if (gfile%nmetavari.gt.0) then
909  idisp=gfile%tlmeta+4
910  iread=len(gfile%variname)*gfile%nmetavari
911  call mpi_file_read_at(gfile%fh,idisp,gfile%variname,iread,mpi_character,status,ios)
912  gfile%tlmeta=gfile%tlmeta+iread+8
913 !
914  idisp=gfile%tlmeta+4
915  iread=gfile%nmetavari
916  call mpi_file_read_at(gfile%fh,idisp,gfile%varival,iread,mpi_integer,status,ios)
917  if(gfile%do_byteswap) &
918  call byteswap(gfile%varival,nemsio_intkind,iread)
919  gfile%tlmetavarival=gfile%tlmeta
920  gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8
921  endif
922 !
923 !meta var real
924  if (gfile%nmetavarr.gt.0) then
925  idisp=gfile%tlmeta+4
926  iread=len(gfile%varrname)*gfile%nmetavarr
927  call mpi_file_read_at(gfile%fh,idisp,gfile%varrname,iread,mpi_character,status,ios)
928  gfile%tlmeta=gfile%tlmeta+iread+8
929 !
930  idisp=gfile%tlmeta+4
931  iread=gfile%nmetavarr
932  call mpi_file_read_at(gfile%fh,idisp,gfile%varrval,iread,mpi_real,status,ios)
933  if(gfile%do_byteswap) &
934  call byteswap(gfile%varrval,nemsio_realkind,iread)
935  gfile%tlmeta=gfile%tlmeta+iread*nemsio_realkind+8
936  endif
937 !
938 !meta var logical
939  if (gfile%nmetavarl.gt.0) then
940  idisp=gfile%tlmeta+4
941  iread=len(gfile%varlname)*gfile%nmetavarl
942  call mpi_file_read_at(gfile%fh,idisp,gfile%varlname,iread,mpi_character,status,ios)
943  gfile%tlmeta=gfile%tlmeta+iread+8
944 !
945  idisp=gfile%tlmeta+4
946  iread=gfile%nmetavarl
947  call mpi_file_read_at(gfile%fh,idisp,gfile%varlval,iread,mpi_logical,status,ios)
948  if(gfile%do_byteswap) &
949  call byteswap(gfile%varlval,nemsio_logickind,iread)
950  gfile%tlmeta=gfile%tlmeta+iread*nemsio_logickind+8
951  endif
952 !
953 !meta var character
954  if (gfile%nmetavarc.gt.0) then
955  idisp=gfile%tlmeta+4
956  iread=len(gfile%varcname)*gfile%nmetavarc
957  call mpi_file_read_at(gfile%fh,idisp,gfile%varcname,iread,mpi_character,status,ios)
958  gfile%tlmeta=gfile%tlmeta+iread+8
959 !
960  idisp=gfile%tlmeta+4
961  iread=len(gfile%varcname)*gfile%nmetavarc
962  call mpi_file_read_at(gfile%fh,idisp,gfile%varcval,iread,mpi_character,status,ios)
963  gfile%tlmeta=gfile%tlmeta+iread+8
964  endif
965 !meta var real 8
966  if (gfile%nmetavarr8.gt.0) then
967  idisp=gfile%tlmeta+4
968  iread=len(gfile%varr8name)*gfile%nmetavarr8
969  call mpi_file_read_at(gfile%fh,idisp,gfile%varr8name,iread,mpi_character,status,ios)
970  gfile%tlmeta=gfile%tlmeta+iread+8
971 !
972  idisp=gfile%tlmeta+4
973  iread=gfile%nmetavarr8
974  call mpi_file_read_at(gfile%fh,idisp,gfile%varr8val,iread,mpi_real8,status,ios)
975  if(gfile%do_byteswap) &
976  call byteswap(gfile%varr8val,nemsio_dblekind,iread)
977  gfile%tlmeta=gfile%tlmeta+iread*nemsio_dblekind+8
978  endif
979 !
980 !meta arr integer
981  if (gfile%nmetaaryi.gt.0) then
982  idisp=gfile%tlmeta+4
983  iread=len(gfile%aryiname)*gfile%nmetaaryi
984  call mpi_file_read_at(gfile%fh,idisp,gfile%aryiname,iread,mpi_character,status,ios)
985  gfile%tlmeta=gfile%tlmeta+iread+8
986 !
987  idisp=gfile%tlmeta+4
988  iread=gfile%nmetaaryi
989  call mpi_file_read_at(gfile%fh,idisp,gfile%aryilen,iread,mpi_integer,status,ios)
990  if(gfile%do_byteswap) &
991  call byteswap(gfile%aryilen,nemsio_intkind,iread)
992  gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8
993 !
994  allocate(gfile%aryival(maxval(gfile%aryilen),gfile%nmetaaryi))
995  do i=1,gfile%nmetaaryi
996  idisp=gfile%tlmeta+4
997  iread=gfile%aryilen(i)
998  call mpi_file_read_at(gfile%fh,idisp,gfile%aryival(1:iread,i),iread,mpi_integer,status,ios)
999  if(gfile%do_byteswap) &
1000  call byteswap(gfile%aryival(:,i),nemsio_intkind,iread)
1001  gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8
1002  enddo
1003  endif
1004 !meta arr real
1005  if (gfile%nmetaaryr.gt.0) then
1006  idisp=gfile%tlmeta+4
1007  iread=len(gfile%aryrname)*gfile%nmetaaryr
1008  call mpi_file_read_at(gfile%fh,idisp,gfile%aryrname,iread,mpi_character,status,ios)
1009  gfile%tlmeta=gfile%tlmeta+iread+8
1010 !
1011  idisp=gfile%tlmeta+4
1012  iread=gfile%nmetaaryr
1013  call mpi_file_read_at(gfile%fh,idisp,gfile%aryrlen,iread,mpi_integer,status,ios)
1014  if(gfile%do_byteswap) &
1015  call byteswap(gfile%aryrlen,nemsio_intkind,iread)
1016  gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8
1017 !
1018  allocate(gfile%aryrval(maxval(gfile%aryrlen),gfile%nmetaaryr))
1019  do i=1,gfile%nmetaaryr
1020  idisp=gfile%tlmeta+4
1021  iread=gfile%aryrlen(i)
1022  call mpi_file_read_at(gfile%fh,idisp,gfile%aryrval(1:iread,i),iread,mpi_real,status,ios)
1023  if(gfile%do_byteswap) &
1024  call byteswap(gfile%aryrval(1:iread,i),nemsio_realkind,iread)
1025  gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8
1026  enddo
1027  endif
1028 !meta arr logical
1029  if (gfile%nmetaaryl.gt.0) then
1030  idisp=gfile%tlmeta+4
1031  iread=len(gfile%arylname)*gfile%nmetaaryl
1032  call mpi_file_read_at(gfile%fh,idisp,gfile%arylname,iread,mpi_character,status,ios)
1033  gfile%tlmeta=gfile%tlmeta+iread+8
1034 !
1035  idisp=gfile%tlmeta+4
1036  iread=gfile%nmetaaryl
1037  call mpi_file_read_at(gfile%fh,idisp,gfile%aryllen,iread,mpi_integer,status,ios)
1038  if(gfile%do_byteswap) &
1039  call byteswap(gfile%aryllen,nemsio_intkind,iread)
1040  gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8
1041 !
1042  allocate(gfile%arylval(maxval(gfile%aryllen),gfile%nmetaaryl))
1043  do i=1,gfile%nmetaaryl
1044  idisp=gfile%tlmeta+4
1045  iread=gfile%aryllen(i)
1046  call mpi_file_read_at(gfile%fh,idisp,gfile%arylval(1:iread,i),iread,mpi_logical,status,ios)
1047  if(gfile%do_byteswap) &
1048  call byteswap(gfile%arylval(1:iread,i),nemsio_logickind,iread)
1049  gfile%tlmeta=gfile%tlmeta+iread*nemsio_logickind+8
1050  enddo
1051  endif
1052 !meta arr char
1053  if (gfile%nmetaaryc.gt.0) then
1054  idisp=gfile%tlmeta+4
1055  iread=len(gfile%arycname)*gfile%nmetaaryc
1056  call mpi_file_read_at(gfile%fh,idisp,gfile%arycname,iread,mpi_character,status,ios)
1057  gfile%tlmeta=gfile%tlmeta+iread+8
1058 !
1059  idisp=gfile%tlmeta+4
1060  iread=gfile%nmetaaryc
1061  call mpi_file_read_at(gfile%fh,idisp,gfile%aryclen,iread,mpi_integer,status,ios)
1062  if(gfile%do_byteswap) &
1063  call byteswap(gfile%aryclen,nemsio_intkind,gfile%nmetaaryc)
1064  gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8
1065 !
1066  allocate(gfile%arycval(maxval(gfile%aryclen),gfile%nmetaaryc))
1067  do i=1,gfile%nmetaaryc
1068  idisp=gfile%tlmeta+4
1069  iread=gfile%aryclen(i)*len(gfile%arycval)
1070  call mpi_file_read_at(gfile%fh,idisp,gfile%arycval(1:iread,i),iread,mpi_character,status,ios)
1071  gfile%tlmeta=gfile%tlmeta+iread+8
1072  enddo
1073  endif
1074 !meta arr real8
1075  if (gfile%nmetaaryr8.gt.0) then
1076  idisp=gfile%tlmeta+4
1077  iread=len(gfile%aryr8name)*gfile%nmetaaryr8
1078  call mpi_file_read_at(gfile%fh,idisp,gfile%aryr8name,iread,mpi_character,status,ios)
1079  gfile%tlmeta=gfile%tlmeta+iread+8
1080 !
1081  idisp=gfile%tlmeta+4
1082  iread=gfile%nmetaaryr8
1083  call mpi_file_read_at(gfile%fh,idisp,gfile%aryr8len,iread,mpi_integer,status,ios)
1084  if(gfile%do_byteswap) &
1085  call byteswap(gfile%aryr8len,nemsio_intkind,iread)
1086  gfile%tlmeta=gfile%tlmeta+iread*nemsio_intkind+8
1087 !
1088  allocate(gfile%aryr8val(maxval(gfile%aryr8len),gfile%nmetaaryr8))
1089  do i=1,gfile%nmetaaryr8
1090  idisp=gfile%tlmeta+4
1091  iread=gfile%aryr8len(i)
1092  call mpi_file_read_at(gfile%fh,idisp,gfile%aryr8val(1:iread,i),iread,mpi_real,status,ios)
1093  if(gfile%do_byteswap) &
1094  call byteswap(gfile%aryr8val(1:iread,i),nemsio_dblekind,iread)
1095  gfile%tlmeta=gfile%tlmeta+iread*nemsio_dblekind+8
1096  enddo
1097  endif
1098 !
1099 !end if extrameta
1100  endif extrameta_if
1101 !
1102  call mpi_barrier(gfile%mpi_comm, ios)
1103 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
1104  iret=0
1105  end subroutine nemsio_rcreate
1106 !------------------------------------------------------------------------------
1107  subroutine nemsio_wcreate(gfile,iret,gdatatype,version, &
1108  nmeta,lmeta,modelname,nrec,idate,nfday,nfhour,nfminute,nfsecondn, &
1109  nfsecondd, &
1110  dimx,dimy,dimz,nframe,nsoil,ntrac,jcap,ncldt,idvc,idsl,idvm,idrt, &
1111  rlon_min,rlon_max,rlat_min,rlat_max,extrameta, &
1112  nmetavari,nmetavarr,nmetavarl,nmetavarc,nmetavarr8, &
1113  nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc,nmetaaryr8, &
1114  recname,reclevtyp,reclev,vcoord,lat,lon,dx,dy,cpi,ri, &
1115  variname,varival,varrname,varrval,varlname,varlval,varcname,varcval, &
1116  varr8name,varr8val, &
1117  aryiname,aryilen,aryival,aryrname,aryrlen,aryrval, &
1118  arylname,aryllen,arylval,arycname,aryclen,arycval, &
1119  aryr8name,aryr8len,aryr8val )
1120 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
1121 ! abstract: write nemsio meta data
1122 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
1123  implicit none
1124  type(nemsio_gfile),intent(inout) :: gfile
1125  integer(nemsio_intkind),intent(out) :: iret
1126 !optional variables
1127  character*(*),optional,intent(in) :: gdatatype,modelname
1128  integer(nemsio_intkind),optional,intent(in) :: version,nmeta,lmeta,nrec
1129  integer(nemsio_intkind),optional,intent(in) :: idate(7),nfday,nfhour, &
1130  nfminute,nfsecondn,nfsecondd
1131  integer(nemsio_logickind),optional,intent(in):: dimx,dimy,dimz,nframe, &
1132  nsoil,ntrac
1133  integer(nemsio_logickind),optional,intent(in):: jcap,ncldt,idvc,idsl, &
1134  idvm,idrt
1135  real(nemsio_realkind),optional,intent(in) :: rlat_min,rlat_max, &
1136  rlon_min,rlon_max
1137  logical(nemsio_logickind),optional,intent(in):: extrameta
1138  integer(nemsio_intkind),optional,intent(in) :: nmetavari,nmetavarr, &
1139  nmetavarl,nmetavarc,nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc, &
1140  nmetavarr8,nmetaaryr8
1141 !
1142  character*(*),optional,intent(in) :: recname(:),reclevtyp(:)
1143  integer(nemsio_intkind),optional,intent(in) :: reclev(:)
1144  real(nemsio_realkind),optional,intent(in) :: vcoord(:,:,:)
1145  real(nemsio_realkind),optional,intent(in) :: lat(:),lon(:)
1146  real(nemsio_realkind),optional,intent(in) :: dx(:),dy(:)
1147  real(nemsio_realkind),optional,intent(in) :: Cpi(:),Ri(:)
1148 !
1149  character*(*),optional,intent(in) :: variname(:),varrname(:),&
1150  varlname(:),varcname(:),varr8name(:),aryiname(:),aryrname(:), &
1151  arylname(:),arycname(:),aryr8name(:)
1152  integer(nemsio_intkind),optional,intent(in) :: aryilen(:),aryrlen(:), &
1153  aryllen(:),aryclen(:),aryr8len(:)
1154  integer(nemsio_intkind),optional,intent(in) :: varival(:),aryival(:,:)
1155  real(nemsio_realkind),optional,intent(in) :: varrval(:),aryrval(:,:)
1156  real(nemsio_dblekind),optional,intent(in) :: varr8val(:),aryr8val(:,:)
1157  logical(nemsio_logickind),optional,intent(in):: varlval(:),arylval(:,:)
1158  character(*),optional,intent(in) :: varcval(:),arycval(:,:)
1159 !
1160 !--- local variables
1161 !
1162  real(nemsio_realkind) :: radi
1163  integer(nemsio_intkind) :: iwrite,nwrite
1164  type(nemsio_meta1) :: meta1
1165  type(nemsio_meta2) :: meta2
1166  type(nemsio_meta3) :: meta3
1167  integer(nemsio_intkind) :: i,n,ios,nummeta
1168  integer :: status(MPI_STATUS_SIZE)
1169  integer (kind=mpi_offset_kind) :: idisp
1170  logical :: linit
1171 !------------------------------------------------------------
1172 ! set gfile meta data to operational model (default) if it's empty
1173 !------------------------------------------------------------
1174  iret=-3
1175  gfile%gtype="NEMSIO"
1176  gfile%do_byteswap=.false.
1177  if(present(gdatatype)) then
1178  if ( trim(gdatatype).ne.'grib'.and.gdatatype(1:3).ne.'bin'.and. &
1179  trim(gdatatype).ne.'') return
1180  gfile%gdatatype=gdatatype
1181  if(trim(gdatatype)=='') gfile%gdatatype='grib'
1182  if(index(gfile%gdatatype,'_be')>0) then
1183  gfile%file_endian='big_endian'
1184  elseif(index(gfile%gdatatype,'_le')>0) then
1185  gfile%file_endian='little_endian'
1186  else
1187  gfile%file_endian=machine_endian
1188  endif
1189  if(trim(machine_endian)/=trim(gfile%file_endian)) gfile%do_byteswap=.true.
1190  elseif(trim(gfile%gdatatype).eq.'') then
1191  gfile%gdatatype='grib'
1192  endif
1193 ! print *,'in wcreate,mype=',gfile%mype,'file_endian=',gfile%file_endian, &
1194 ! 'machine_endian=',machine_endian
1195 
1196  if(present(modelname)) then
1197  gfile%modelname=modelname
1198  else
1199  gfile%modelname="GFS"
1200  endif
1201 ! print *,'NEMSIO file,datatype,model is ',gfile%gtype, &
1202 ! gfile%gdatatype,gfile%modelname,idate(1:7),'machine_endian=', &
1203 ! machine_endian,'gfile%file_endian=',gfile%file_endian,'gfile%do_byteswap=',gfile%do_byteswap
1204  if(present(version)) gfile%version=version
1205  if(present(dimx)) gfile%dimx=dimx
1206  if(present(dimy)) gfile%dimy=dimy
1207  if(present(dimz)) gfile%dimz=dimz
1208  if(present(nrec)) gfile%nrec=nrec
1209  if(present(nmeta)) gfile%nmeta=nmeta
1210  if(gfile%nmeta==nemsio_intfill) gfile%nmeta=12
1211  if(present(lmeta)) gfile%lmeta=lmeta
1212  if(gfile%lmeta==nemsio_intfill) &
1213  gfile%lmeta=25*nemsio_intkind+4*nemsio_realkind+nemsio_logickind
1214  if(present(nsoil)) gfile%nsoil=nsoil
1215  if(gfile%nsoil.eq.nemsio_intfill) gfile%nsoil=4
1216  if(present(nframe)) gfile%nframe=nframe
1217  if(gfile%nframe.eq.nemsio_intfill) gfile%nframe=0
1218  if(trim(gfile%modelname)=='GFS')gfile%nframe=0
1219  if(present(idate)) gfile%idate=idate
1220  if ( gfile%idate(1) .lt. 50) then
1221  gfile%idate(1)=2000+gfile%idate(1)
1222  else if (gfile%idate(1) .lt. 100) then
1223  gfile%idate(1)=1999+gfile%idate(1)
1224  endif
1225  if ( gfile%idate(1).eq.nemsio_intfill) then
1226  print *,'idate=',gfile%idate,' WRONG: please provide idate(1:7)(yyyy/mm/dd/hh/min/secn/secd)!!!'
1227  call nemsio_stop()
1228  endif
1229 !
1230  if ( gfile%gtype(1:6).eq."NEMSIO" ) then
1231  call nemsio_gfinit(gfile,ios,recname=recname,reclevtyp=reclevtyp,reclev=reclev)
1232  if (ios .ne.0 ) then
1233  iret=ios
1234  return
1235  endif
1236  endif
1237 !
1238 !------------------------------------------------------------
1239 ! set up basic gfile meta data variables from outsides to
1240 ! define meta data array
1241 !------------------------------------------------------------
1242  if(present(nfday)) gfile%nfday=nfday
1243  if(present(nfhour)) gfile%nfhour=nfhour
1244  if(present(nfminute)) gfile%nfminute=nfminute
1245  if(present(nfsecondn)) gfile%nfsecondn=nfsecondn
1246  if(present(nfsecondd)) gfile%nfsecondd=nfsecondd
1247  if(present(ntrac)) gfile%ntrac=ntrac
1248  if(gfile%ntrac.eq.nemsio_intfill) gfile%ntrac=0
1249  if(present(ncldt)) gfile%ncldt=ncldt
1250  if(present(jcap)) gfile%jcap=jcap
1251  if(present(idvc)) gfile%idvc=idvc
1252  if(present(idsl)) gfile%idsl=idsl
1253  if(present(idvm)) gfile%idvm=idvm
1254  if(present(idrt)) gfile%idrt=idrt
1255  if(present(rlon_min)) gfile%rlon_min=rlon_min
1256  if(present(rlon_max)) gfile%rlon_max=rlon_max
1257  if(present(rlat_min)) gfile%rlat_min=rlat_min
1258  if(present(rlat_max)) gfile%rlat_max=rlat_max
1259  if(present(extrameta)) gfile%extrameta=extrameta
1260  if(gfile%fieldsize.eq.nemsio_intfill) &
1261  gfile%fieldsize=(gfile%dimx+2*gfile%nframe)*(gfile%dimy+2*gfile%nframe)
1262  if(gfile%mype.eq.gfile%lead_task) then
1263  if(gfile%gdatatype(1:4).eq.'bin4') then
1264  call mpi_send(gfile%fieldsize*nemsio_realkind,1,mpi_integer,0,99,gfile%mpi_comm,ios)
1265  call mpi_recv(gfile%fieldsize_real4,1,mpi_real4,0,99,gfile%mpi_comm,status,ios)
1266  elseif(gfile%gdatatype(1:4).eq.'bin8') then
1267  call mpi_send(gfile%fieldsize*nemsio_dblekind,1,mpi_integer,0,99,gfile%mpi_comm,ios)
1268  call mpi_recv(gfile%fieldsize_real8,1,mpi_real8,0,99,gfile%mpi_comm,status,ios)
1269  endif
1270  endif
1271 !
1272 !---------------------------------------------------------------------
1273 !*** for lead write task
1274 !---------------------------------------------------------------------
1275 !
1276  if(gfile%mype.eq.gfile%lead_task) then
1277 !
1278  if( gfile%extrameta )then
1279  if(present(nmetavari).and.present(variname).and.present(varival)) then
1280  if(nmetavari.gt.0 .and.size(variname).eq.nmetavari .and. &
1281  size(varival).eq.nmetavari) then
1282  gfile%nmetavari=nmetavari
1283  if(allocated(gfile%variname)) deallocate(gfile%variname)
1284  if(allocated(gfile%varival)) deallocate(gfile%varival)
1285  allocate(gfile%variname(nmetavari),gfile%varival(nmetavari))
1286  gfile%variname=variname
1287  gfile%varival=varival
1288  endif
1289  endif
1290  if(present(nmetavarr).and.present(varrname).and.present(varrval)) then
1291  if( nmetavarr.gt.0.and.size(varrname).eq.nmetavarr .and. &
1292  size(varrval).eq.nmetavarr) then
1293  gfile%nmetavarr=nmetavarr
1294  if(allocated(gfile%varrname)) deallocate(gfile%varrname)
1295  if(allocated(gfile%varrval)) deallocate(gfile%varrval)
1296  allocate(gfile%varrname(nmetavarr),gfile%varrval(nmetavarr))
1297  gfile%varrname=varrname
1298  gfile%varrval=varrval
1299  endif
1300  endif
1301  if(present(nmetavarl).and.present(varlname).and.present(varlval)) then
1302  if( nmetavarl.gt.0.and.size(varlname).eq.nmetavarl .and. &
1303  size(varlval).eq.nmetavarl) then
1304  gfile%nmetavarl=nmetavarl
1305  if(allocated(gfile%varlname)) deallocate(gfile%varlname)
1306  if(allocated(gfile%varlval)) deallocate(gfile%varlval)
1307  allocate(gfile%varlname(nmetavarl),gfile%varlval(nmetavarl))
1308  gfile%varlname=varlname
1309  gfile%varlval=varlval
1310  endif
1311  endif
1312  if(present(nmetavarc).and.present(varcname).and.present(varcval)) then
1313  if( nmetavarc.gt.0.and.size(varcname).eq.nmetavarc .and. &
1314  size(varcval).eq.nmetavarc) then
1315  gfile%nmetavarc=nmetavarc
1316  if(allocated(gfile%varcname)) deallocate(gfile%varcname)
1317  if(allocated(gfile%varcval)) deallocate(gfile%varcval)
1318  allocate(gfile%varcname(nmetavarc),gfile%varcval(nmetavarc))
1319  gfile%varcname=varcname
1320  gfile%varcval=varcval
1321  endif
1322  endif
1323  if(present(nmetavarr8).and.present(varr8name).and.present(varr8val)) then
1324  if( nmetavarr8.gt.0.and.size(varr8name).eq.nmetavarr8 .and. &
1325  size(varr8val).eq.nmetavarr8) then
1326  gfile%nmetavarr8=nmetavarr8
1327  if(allocated(gfile%varr8name)) deallocate(gfile%varr8name)
1328  if(allocated(gfile%varr8val)) deallocate(gfile%varr8val)
1329  allocate(gfile%varr8name(nmetavarr8),gfile%varr8val(nmetavarr8))
1330  gfile%varr8name=varr8name
1331  gfile%varr8val=varr8val
1332  endif
1333  endif
1334  if(present(nmetaaryi).and.present(aryiname).and.present(aryilen)) then
1335  if( nmetaaryi.gt.0.and.size(aryiname).eq.nmetaaryi .and. &
1336  size(aryilen).eq.nmetaaryi) then
1337  gfile%nmetaaryi=nmetaaryi
1338  if(allocated(gfile%aryiname)) deallocate(gfile%aryiname)
1339  if(allocated(gfile%aryilen)) deallocate(gfile%aryilen)
1340  allocate(gfile%aryiname(nmetaaryi),gfile%aryilen(nmetaaryi))
1341  gfile%aryiname=aryiname
1342  gfile%aryilen=aryilen
1343  if(present(aryival)) then
1344  if(size(aryival).eq.nmetaaryi*maxval(gfile%aryilen) ) then
1345  if(allocated(gfile%aryival)) deallocate(gfile%aryival)
1346  allocate(gfile%aryival(maxval(gfile%aryilen),nmetaaryi))
1347  gfile%aryival=aryival
1348  endif
1349  endif
1350  endif
1351  endif
1352  if(present(nmetaaryr).and.present(aryrname).and.present(aryrlen)) then
1353  if( nmetaaryr.gt.0.and.size(aryrname).eq.nmetaaryr .and. &
1354  size(aryrlen).eq.nmetaaryr) then
1355  gfile%nmetaaryr=nmetaaryr
1356  if(allocated(gfile%aryrname)) deallocate(gfile%aryrname)
1357  if(allocated(gfile%aryrlen)) deallocate(gfile%aryrlen)
1358  allocate(gfile%aryrname(nmetaaryr),gfile%aryrlen(nmetaaryr))
1359  gfile%aryrname=aryrname
1360  gfile%aryrlen=aryrlen
1361  if(present(aryrval) ) then
1362  if(size(aryrval).eq.nmetaaryr*maxval(gfile%aryrlen)) then
1363  if(allocated(gfile%aryrval)) deallocate(gfile%aryrval)
1364  allocate(gfile%aryrval(maxval(gfile%aryrlen),nmetaaryr))
1365  gfile%aryrval=aryrval
1366  endif
1367  endif
1368  endif
1369  endif
1370  if(present(nmetaaryl).and.present(arylname).and.present(aryllen)) then
1371  if( nmetaaryl.gt.0 .and.size(arylname).eq.nmetaaryl .and. &
1372  size(aryllen).eq.nmetaaryl) then
1373  gfile%nmetaaryl=nmetaaryl
1374  if(allocated(gfile%arylname)) deallocate(gfile%arylname)
1375  if(allocated(gfile%aryllen)) deallocate(gfile%aryllen)
1376  allocate(gfile%arylname(nmetaaryl),gfile%aryllen(nmetaaryl))
1377  gfile%arylname=arylname
1378  gfile%aryllen=aryllen
1379  if(present(arylval)) then
1380  if(size(arylval).eq.nmetaaryl*maxval(gfile%aryllen)) then
1381  if(allocated(gfile%arylval)) deallocate(gfile%arylval)
1382  allocate(gfile%arylval(maxval(gfile%aryllen),nmetaaryl))
1383  gfile%arylval=arylval
1384  endif
1385  endif
1386  endif
1387  endif
1388  if(present(nmetaaryc).and.present(arycname).and.present(aryclen)) then
1389  if( nmetaaryc.gt.0 .and.size(arycname).eq.nmetaaryc .and. &
1390  size(aryclen).eq.nmetaaryc) then
1391  gfile%nmetaaryc=nmetaaryc
1392  if(allocated(gfile%arycname)) deallocate(gfile%arycname)
1393  if(allocated(gfile%aryclen)) deallocate(gfile%aryclen)
1394  allocate(gfile%arycname(nmetaaryc),gfile%aryclen(nmetaaryc))
1395  gfile%arycname=arycname
1396  gfile%aryclen=aryclen
1397  if(present(arycval)) then
1398  if(size(arycval).eq.nmetaaryc*maxval(gfile%aryclen)) then
1399  if(allocated(gfile%arycval)) deallocate(gfile%arycval)
1400  allocate(gfile%arycval(maxval(gfile%aryclen),nmetaaryc))
1401  gfile%arycval=arycval
1402  endif
1403  endif
1404  endif
1405  endif
1406  if(present(nmetaaryr8).and.present(aryr8name).and.present(aryr8len)) then
1407  if( nmetaaryr8.gt.0.and.size(aryr8name).eq.nmetaaryr8 .and. &
1408  size(aryr8len).eq.nmetaaryr8) then
1409  gfile%nmetaaryr8=nmetaaryr8
1410  if(allocated(gfile%aryr8name)) deallocate(gfile%aryr8name)
1411  if(allocated(gfile%aryr8len)) deallocate(gfile%aryr8len)
1412  allocate(gfile%aryr8name(nmetaaryr8),gfile%aryr8len(nmetaaryr8))
1413  gfile%aryr8name=aryr8name
1414  gfile%aryr8len=aryr8len
1415  if(present(aryr8val) ) then
1416  if(size(aryr8val).eq.nmetaaryr8*maxval(gfile%aryr8len)) then
1417  if(allocated(gfile%aryr8val)) deallocate(gfile%aryr8val)
1418  allocate(gfile%aryr8val(maxval(gfile%aryr8len),nmetaaryr8))
1419  gfile%aryr8val=aryr8val
1420  endif
1421  endif
1422  endif
1423  endif
1424  if (gfile%nmetavari+gfile%nmetavarr+gfile%nmetavarl+gfile%nmetavarc+ &
1425  gfile%nmetaaryi+gfile%nmetaaryr+gfile%nmetaaryl+gfile%nmetaaryc+ &
1426  gfile%nmetavarr8+gfile%nmetaaryr8 .lt.10*nemsio_intfill )then
1427  print *,'WRONG: gfile%extrameta is not compatiable with input extra meta!'
1428  return
1429  endif
1430  endif
1431 !
1432 !------------------------------------------------------------
1433 ! check gfile meta data array size
1434 !------------------------------------------------------------
1435  call nemsio_chkgfary(gfile,ios)
1436  if (ios.ne. 0) then
1437  iret=ios
1438  return
1439  endif
1440 !------------------------------------------------------------
1441 ! continue to set gfile meta data variables tnd arrays
1442 !------------------------------------------------------------
1443 !set gfile data type to bin/grb, default set to grb
1444 !recname
1445  nummeta=2
1446  if(present(recname) ) then
1447  if (gfile%nrec.eq.size(recname)) then
1448  gfile%recname=recname
1449  else
1450  print *,'WRONG: the size of recname is not equal to the total number of the fields in the file!'
1451  return
1452  endif
1453  nummeta=nummeta+1
1454  endif
1455 !reclevtyp
1456  if(present(reclevtyp)) then
1457  if (gfile%nrec.eq.size(reclevtyp)) then
1458  gfile%reclevtyp=reclevtyp
1459  else
1460  print *,'WRONG: the size of reclevtyp is not equal to the total number of the fields in the file!'
1461  return
1462  endif
1463  nummeta=nummeta+1
1464  endif
1465 !reclev
1466  if(present(reclev) ) then
1467  if (gfile%nrec.eq.size(reclev)) then
1468  gfile%reclev=reclev
1469  else
1470  print *,'WRONG: the size of reclev is not equal to the total number of the fields in the file!'
1471  return
1472  endif
1473  nummeta=nummeta+1
1474  endif
1475 !vcoord vcoord(levs+1
1476  if(present(vcoord) ) then
1477  if ((gfile%dimz+1)*3*2.eq.size(vcoord)) then
1478  gfile%vcoord=vcoord
1479  else
1480  print *,'WRONG: the size of vcoord is not (lm+1,3,2) !'
1481  return
1482  endif
1483  nummeta=nummeta+1
1484  endif
1485 !lat
1486  if(present(lat) ) then
1487  if (gfile%fieldsize.eq.size(lat)) then
1488  if(.not.(all(lat==0.))) gfile%lat=lat
1489  else
1490  print *,'WRONG: the input size(lat) ',size(lat),' is not equal to: ',gfile%fieldsize
1491  return
1492  endif
1493  nummeta=nummeta+1
1494  endif
1495  if(allocated(gfile%lat)) then
1496  gfile%rlat_max=maxval(gfile%lat)
1497  gfile%rlat_min=minval(gfile%lat)
1498  endif
1499 !lon
1500  if(present(lon) ) then
1501  if (gfile%fieldsize.eq.size(lon)) then
1502  if(.not.(all(lon==0.)) ) gfile%lon=lon
1503  else
1504  print *,'WRONG: the input size(lon) ',size(lon),' is not equal to: ',gfile%fieldsize
1505  return
1506  endif
1507  nummeta=nummeta+1
1508  endif
1509  if(allocated(gfile%lon)) then
1510  gfile%rlon_max=maxval(gfile%lon)
1511  gfile%rlon_min=minval(gfile%lon)
1512  endif
1513 !dx
1514  if(present(dx) ) then
1515  if (gfile%fieldsize.eq.size(dx)) then
1516  if(.not.(all(dx==0.)) ) gfile%dx=dx
1517  else
1518  print *,'WRONG: the input size(dx) ',size(dx),' is not equal to: ',gfile%fieldsize
1519  return
1520  endif
1521  nummeta=nummeta+1
1522  endif
1523 !dy
1524  if(present(dy) ) then
1525  if (gfile%fieldsize.eq.size(dy)) then
1526  if(.not.(all(dy==0.)) ) gfile%dy=dy
1527  else
1528  print *,'WRONG: the input size(dy) ',size(dy),' is not equal to: ',gfile%fieldsize
1529  return
1530  endif
1531  nummeta=nummeta+1
1532  endif
1533 !Cpi
1534  if( present(cpi) ) then
1535  if (gfile%ntrac+1.eq.size(gfile%Cpi)) then
1536  if(.not.(all(cpi==0.))) gfile%Cpi = cpi
1537  else
1538  print *,'WRONG: the input size(cpi) ',size(cpi),' is not equal to: ',gfile%ntrac+1
1539  return
1540  endif
1541  nummeta=nummeta+1
1542  endif
1543 !Ri
1544  if( present(ri) ) then
1545  if (gfile%ntrac+1.eq.size(gfile%Ri)) then
1546  if(.not.(all(ri==0.))) gfile%Ri = ri
1547  else
1548  print *,'WRONG: the input size(ri) ',size(ri),' is not equal to: ',gfile%ntrac+1
1549  return
1550  endif
1551  nummeta=nummeta+1
1552  endif
1553  if(gfile%nmeta==nemsio_intfill) gfile%nmeta=nummeta
1554 !------------------------------------------------------------
1555 ! write out the header by lead_task
1556 !------------------------------------------------------------
1557 !------------------------------------------------------------
1558 ! write out first meta data record
1559 !------------------------------------------------------------
1560  meta1%gtype=gfile%gtype
1561  meta1%gdatatype=gfile%gdatatype
1562  meta1%modelname=gfile%modelname
1563  meta1%version=gfile%version
1564  meta1%nmeta=gfile%nmeta
1565  meta1%lmeta=gfile%lmeta
1566  meta1%reserve=0
1567  idisp=0
1568  iwrite=nemsio_lmeta1
1569  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1570  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1571  idisp=4
1572  if(gfile%do_byteswap) call byteswap(meta1%version,nemsio_intkind,6)
1573  call mpi_file_write_at(gfile%fh,idisp,meta1,1,itypemeta1,status,ios)
1574  if(gfile%do_byteswap) call byteswap(meta1%version,nemsio_intkind,6)
1575  idisp=4+nemsio_lmeta1
1576  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1577  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1578  gfile%tlmeta=nemsio_lmeta1+8
1579 !------------------------------------------------------------
1580 ! write out second meta data record
1581 !------------------------------------------------------------
1582  meta2%nrec=gfile%nrec
1583  meta2%idate(1:7)=gfile%idate(1:7)
1584  meta2%nfday=gfile%nfday
1585  meta2%nfhour=gfile%nfhour
1586  meta2%nfminute=gfile%nfminute
1587  meta2%nfsecondn=gfile%nfsecondn
1588  meta2%nfsecondd=gfile%nfsecondd
1589  meta2%dimx=gfile%dimx
1590  meta2%dimy=gfile%dimy
1591  meta2%dimz=gfile%dimz
1592  meta2%nframe=gfile%nframe
1593  meta2%nsoil=gfile%nsoil
1594  meta2%ntrac=gfile%ntrac
1595  meta2%jcap=gfile%jcap
1596  meta2%ncldt=gfile%ncldt
1597  meta2%idvc=gfile%idvc
1598  meta2%idsl=gfile%idsl
1599  meta2%idvm=gfile%idvm
1600  meta2%idrt=gfile%idrt
1601  meta2%rlon_min=gfile%rlon_min
1602  meta2%rlon_max=gfile%rlon_max
1603  meta2%rlat_min=gfile%rlat_min
1604  meta2%rlat_max=gfile%rlat_max
1605  meta2%extrameta=gfile%extrameta
1606  idisp=gfile%tlmeta
1607  iwrite=gfile%lmeta
1608  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1609  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1610  if(gfile%do_byteswap) then
1611  call byteswap(meta2%nrec,nemsio_intkind,25)
1612  call byteswap(meta2%rlon_min,nemsio_realkind,4)
1613  call byteswap(meta2%extrameta,nemsio_logickind,1)
1614  endif
1615  idisp=idisp+4
1616  call mpi_file_write_at(gfile%fh,idisp,meta2,1,itypemeta2,status,ios)
1617  if(gfile%do_byteswap) then
1618  call byteswap(meta2%nrec,nemsio_intkind,25)
1619  call byteswap(meta2%rlon_min,nemsio_realkind,4)
1620  call byteswap(meta2%extrameta,nemsio_logickind,1)
1621  endif
1622  idisp=idisp+gfile%lmeta
1623  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1624  gfile%tlmeta=gfile%tlmeta+gfile%lmeta+8
1625 ! print *,'tlmet2 =',gfile%tlmeta,'nwrite=',nwrite,'meta2=', &
1626 ! meta2%dimx,meta2%dimy,meta2%dimz,meta2%nframe,meta2%nsoil, &
1627 ! meta2%ntrac,meta2%jcap,meta2%ncldt,meta2%idvc,meta2%idsl, &
1628 ! meta2%idvm,meta2%idrt,meta2%rlon_min,meta2%rlon_max, &
1629 ! meta2%rlat_min,meta2%rlat_max,meta2%extrameta
1630  nummeta=gfile%nmeta
1631 !------------------------------------------------------------
1632 ! write out 3rd-13th meta data record (arrays)
1633 !------------------------------------------------------------
1634 !recname
1635  if( nummeta>2) then
1636  idisp=gfile%tlmeta
1637  iwrite=nemsio_charkind*size(gfile%recname)
1638  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1639  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1640  idisp=idisp+4
1641  call mpi_file_write_at(gfile%fh,idisp,gfile%recname,iwrite,mpi_character,status,ios)
1642  if(ios<0) return
1643  idisp=idisp+nemsio_charkind*size(gfile%recname)
1644  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1645  gfile%tlmeta=gfile%tlmeta+nemsio_charkind*size(gfile%recname)+8
1646  endif
1647 !reclevtyp
1648  if( nummeta>3) then
1649  idisp=gfile%tlmeta
1650  iwrite=nemsio_charkind*size(gfile%reclevtyp)
1651  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1652  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1653  idisp=idisp+4
1654  call mpi_file_write_at(gfile%fh,idisp,gfile%reclevtyp,iwrite,mpi_character,status,ios)
1655  if(ios<0) return
1656  idisp=idisp+nemsio_charkind*size(gfile%recname)
1657  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1658  gfile%tlmeta=gfile%tlmeta+nemsio_charkind*size(gfile%reclevtyp)+8
1659  endif
1660 !reclev
1661  if( nummeta>4) then
1662  idisp=gfile%tlmeta
1663  iwrite=nemsio_intkind*size(gfile%reclev)
1664  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1665  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1666  idisp=idisp+4
1667  if(gfile%do_byteswap) call byteswap(gfile%reclev,nemsio_intkind,size(gfile%reclev))
1668  call mpi_file_write_at(gfile%fh,idisp,gfile%reclev,size(gfile%reclev),mpi_integer,status,ios)
1669  if(ios<0) return
1670  idisp=idisp+nemsio_intkind*size(gfile%reclev)
1671  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1672  gfile%tlmeta=gfile%tlmeta+nemsio_intkind*size(gfile%reclev)+8
1673  endif
1674 !vcoord
1675  if ( nummeta>5 ) then
1676  idisp=gfile%tlmeta
1677  iwrite=nemsio_realkind*size(gfile%vcoord)
1678  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1679  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1680  idisp=idisp+4
1681  if(gfile%do_byteswap) call byteswap(gfile%vcoord,nemsio_realkind,size(gfile%vcoord))
1682  call mpi_file_write_at(gfile%fh,idisp,gfile%vcoord,size(gfile%vcoord),mpi_real,status,ios)
1683  if(ios<0) return
1684  if(gfile%do_byteswap) call byteswap(gfile%vcoord,nemsio_realkind,size(gfile%vcoord))
1685  idisp=idisp+nemsio_realkind*size(gfile%vcoord)
1686  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1687  gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%vcoord)+8
1688  endif
1689 !lat
1690  if ( nummeta>6 ) then
1691  idisp=gfile%tlmeta
1692  iwrite=nemsio_realkind*size(gfile%lat)
1693  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1694  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1695  idisp=idisp+4
1696  if(gfile%do_byteswap) call byteswap(gfile%lat,nemsio_realkind,size(gfile%lat))
1697  call mpi_file_write_at(gfile%fh,idisp,gfile%lat,gfile%fieldsize,mpi_real,status,ios)
1698  if(ios<0) return
1699  if(gfile%do_byteswap) call byteswap(gfile%lat,nemsio_realkind,size(gfile%lat))
1700  idisp=idisp+nemsio_realkind*size(gfile%lat)
1701  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1702  gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%lat)+8
1703  endif
1704 !lon
1705  if ( nummeta>7 ) then
1706  idisp=gfile%tlmeta
1707  iwrite=nemsio_realkind*size(gfile%lon)
1708  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1709  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1710  idisp=idisp+4
1711  if(gfile%do_byteswap) call byteswap(gfile%lon,nemsio_realkind,size(gfile%lon))
1712  call mpi_file_write_at(gfile%fh,idisp,gfile%lon,gfile%fieldsize,mpi_real,status,ios)
1713  if(ios<0) return
1714  if(gfile%do_byteswap) call byteswap(gfile%lon,nemsio_realkind,size(gfile%lon))
1715  idisp=idisp+nemsio_realkind*size(gfile%lon)
1716  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1717  gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%lat)+8
1718 ! print *,'tlmetreclon=',gfile%tlmeta,'nwrite=',nwrite
1719  endif
1720 !dx
1721  if ( nummeta>8 ) then
1722  idisp=gfile%tlmeta
1723  iwrite=nemsio_realkind*size(gfile%dx)
1724  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1725  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1726  idisp=idisp+4
1727  if(gfile%do_byteswap) call byteswap(gfile%dx,nemsio_realkind,size(gfile%dx))
1728  call mpi_file_write_at(gfile%fh,idisp,gfile%dx,gfile%fieldsize,mpi_real,status,ios)
1729  if(ios<0) return
1730  if(gfile%do_byteswap) call byteswap(gfile%dx,nemsio_realkind,size(gfile%dx))
1731  idisp=idisp+nemsio_realkind*size(gfile%dx)
1732  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1733  gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%dx)+8
1734  endif
1735 !dy
1736  if ( nummeta>9 ) then
1737  idisp=gfile%tlmeta
1738  iwrite=nemsio_realkind*size(gfile%dy)
1739  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1740  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1741  idisp=idisp+4
1742  if(gfile%do_byteswap) call byteswap(gfile%dy,nemsio_realkind,size(gfile%dy))
1743  call mpi_file_write_at(gfile%fh,idisp,gfile%dy,gfile%fieldsize,mpi_real,status,ios)
1744  if(ios<0) return
1745  if(gfile%do_byteswap) call byteswap(gfile%dy,nemsio_realkind,size(gfile%dy))
1746  idisp=idisp+nemsio_realkind*size(gfile%dy)
1747  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1748  gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%dy)+8
1749 ! print *,'tlmetrecdy=',gfile%tlmeta,'nwrite=',nwrite
1750  endif
1751 !Cpi
1752  if ( nummeta>10 ) then
1753  idisp=gfile%tlmeta
1754  iwrite=nemsio_realkind*size(gfile%cpi)
1755  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1756  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1757  idisp=idisp+4
1758  if(gfile%do_byteswap) call byteswap(gfile%cpi,nemsio_realkind,size(gfile%cpi))
1759  call mpi_file_write_at(gfile%fh,idisp,gfile%cpi,size(gfile%cpi),mpi_real,status,ios)
1760  if(ios<0) return
1761  if(gfile%do_byteswap) call byteswap(gfile%cpi,nemsio_realkind,size(gfile%cpi))
1762  idisp=idisp+nemsio_realkind*size(gfile%cpi)
1763  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1764  gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%cpi)+8
1765  endif
1766 !Ri
1767  if ( nummeta>11 ) then
1768  idisp=gfile%tlmeta
1769  iwrite=nemsio_realkind*size(gfile%ri)
1770  if(gfile%do_byteswap) call byteswap(iwrite,nemsio_intkind,1)
1771  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1772  idisp=idisp+4
1773  if(gfile%do_byteswap) call byteswap(gfile%ri,nemsio_realkind,size(gfile%ri))
1774  call mpi_file_write_at(gfile%fh,idisp,gfile%ri,size(gfile%ri),mpi_real,status,ios)
1775  if(ios<0) return
1776  if(gfile%do_byteswap) call byteswap(gfile%ri,nemsio_realkind,size(gfile%ri))
1777  idisp=idisp+nemsio_realkind*size(gfile%ri)
1778  call mpi_file_write_at(gfile%fh,idisp,iwrite,1,mpi_integer,status,ios)
1779  gfile%tlmeta=gfile%tlmeta+nemsio_realkind*size(gfile%ri)+8
1780  endif
1781 !------------------------------------------------------------
1782 ! write out extra meta data record
1783 !------------------------------------------------------------
1784  if(gfile%extrameta) then
1785  meta3%nmetavari=gfile%nmetavari
1786  meta3%nmetavarr=gfile%nmetavarr
1787  meta3%nmetavarl=gfile%nmetavarl
1788  meta3%nmetavarc=gfile%nmetavarc
1789  meta3%nmetaaryi=gfile%nmetaaryi
1790  meta3%nmetaaryr=gfile%nmetaaryr
1791  meta3%nmetaaryl=gfile%nmetaaryl
1792  meta3%nmetaaryc=gfile%nmetaaryc
1793  meta3%nmetavarr8=gfile%nmetavarr8
1794  meta3%nmetaaryr8=gfile%nmetaaryr8
1795  idisp=gfile%tlmeta
1796 !!!!!####!!now iwritewill be nemsio_lmeta3
1797  if(gfile%nmetavarr8>0.or.gfile%nmetaaryr8>0) then
1798  iwrite=nemsio_lmeta3
1799  else
1800  iwrite=nemsio_lmeta3-8
1801  endif
1802  nwrite=iwrite
1803  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1804  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1805  idisp=idisp+4
1806  if(gfile%do_byteswap) &
1807  call byteswap(meta3%nmetavari,nemsio_intkind,iwrite/4)
1808  call mpi_file_write_at(gfile%fh,idisp,meta3,iwrite/4,mpi_integer,status,ios)
1809  if(gfile%do_byteswap) &
1810  call byteswap(meta3%nmetavari,nemsio_intkind,iwrite/4)
1811  idisp=idisp+iwrite
1812  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1813  gfile%tlmeta=gfile%tlmeta+iwrite+8
1814 ! print *,'tlmetameta3=',gfile%tlmeta,'nmetavari=',gfile%nmetavari,gfile%nmetavarr, &
1815 ! gfile%nmetavarl,gfile%nmetavarc,gfile%nmetavarr8,'nmetaaryi=',gfile%nmetaaryi, &
1816 ! gfile%nmetaaryr,gfile%nmetaaryl,gfile%nmetaaryc,gfile%nmetaaryr8,'iwrite=',iwrite
1817 !
1818 !-- write meta var integer
1819  if (gfile%nmetavari.gt.0) then
1820  idisp=gfile%tlmeta
1821  iwrite=len(gfile%variname)*gfile%nmetavari
1822  nwrite=iwrite
1823  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1824  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1825  idisp=idisp+4
1826  call mpi_file_write_at(gfile%fh,idisp,gfile%variname,iwrite,mpi_character,status,ios)
1827  idisp=idisp+iwrite
1828  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1829  gfile%tlmeta=gfile%tlmeta+iwrite+8
1830 !
1831  idisp=gfile%tlmeta
1832  iwrite=gfile%nmetavari
1833  nwrite=iwrite*kind(gfile%varival)
1834  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1835  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1836  idisp=idisp+4
1837  if(gfile%do_byteswap) &
1838  call byteswap(gfile%varival,nemsio_intkind,size(gfile%varival))
1839  call mpi_file_write_at(gfile%fh,idisp,gfile%varival,iwrite,mpi_integer,status,ios)
1840  if(gfile%do_byteswap) &
1841  call byteswap(gfile%varival,nemsio_intkind,size(gfile%varival))
1842  idisp=idisp+iwrite*kind(gfile%varival)
1843  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1844  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%varival)+8
1845  endif
1846 !var real4
1847  if (gfile%nmetavarr.gt.0) then
1848  idisp=gfile%tlmeta
1849  iwrite=len(gfile%varrname)*gfile%nmetavarr
1850  nwrite=iwrite
1851  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1852  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1853  idisp=idisp+4
1854  call mpi_file_write_at(gfile%fh,idisp,gfile%varrname,iwrite,mpi_character,status,ios)
1855  idisp=idisp+iwrite
1856  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1857  gfile%tlmeta=gfile%tlmeta+iwrite+8
1858 
1859  idisp=gfile%tlmeta
1860  iwrite=gfile%nmetavarr
1861  nwrite=iwrite*kind(gfile%varrval)
1862  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1863  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1864  idisp=idisp+4
1865  if(gfile%do_byteswap) &
1866  call byteswap(gfile%varrval,nemsio_realkind,size(gfile%varrval))
1867  call mpi_file_write_at(gfile%fh,idisp,gfile%varrval,iwrite,mpi_real,status,ios)
1868  if(gfile%do_byteswap) &
1869  call byteswap(gfile%varrval,nemsio_realkind,size(gfile%varrval))
1870  idisp=idisp+iwrite*kind(gfile%varrval)
1871  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1872  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%varrval)+8
1873 
1874  endif
1875 !var logical
1876  if (gfile%nmetavarl.gt.0) then
1877  idisp=gfile%tlmeta
1878  iwrite=len(gfile%varlname)*gfile%nmetavarl
1879  nwrite=iwrite
1880  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1881  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1882  idisp=idisp+4
1883  call mpi_file_write_at(gfile%fh,idisp,gfile%varlname,iwrite,mpi_character,status,ios)
1884  idisp=idisp+iwrite
1885  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1886  gfile%tlmeta=gfile%tlmeta+iwrite+8
1887 
1888  idisp=gfile%tlmeta
1889  iwrite=gfile%nmetavarl
1890  nwrite=iwrite*kind(gfile%varlval)
1891  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1892  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1893  idisp=idisp+4
1894  if(gfile%do_byteswap) &
1895  call byteswap(gfile%varlval,nemsio_logickind,size(gfile%varlval))
1896  call mpi_file_write_at(gfile%fh,idisp,gfile%varlval,iwrite,mpi_logical,status,ios)
1897  if(gfile%do_byteswap) &
1898  call byteswap(gfile%varlval,nemsio_logickind,size(gfile%varlval))
1899  idisp=idisp+iwrite*kind(gfile%varlval)
1900  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1901  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%varlval)+8
1902  endif
1903 
1904 !var character
1905  if (gfile%nmetavarc.gt.0) then
1906  idisp=gfile%tlmeta
1907  iwrite=len(gfile%varcname)*gfile%nmetavarc
1908  nwrite=iwrite
1909  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1910  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1911  idisp=idisp+4
1912  call mpi_file_write_at(gfile%fh,idisp,gfile%varcname,iwrite,mpi_character,status,ios)
1913  idisp=idisp+iwrite
1914  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1915  gfile%tlmeta=gfile%tlmeta+iwrite+8
1916 
1917 
1918  idisp=gfile%tlmeta
1919  iwrite=gfile%nmetavarc*len(gfile%varcval)
1920  nwrite=iwrite
1921  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1922  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1923  idisp=idisp+4
1924  call mpi_file_write_at(gfile%fh,idisp,gfile%varcval,iwrite,mpi_character,status,ios)
1925  idisp=idisp+iwrite
1926  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1927  gfile%tlmeta=gfile%tlmeta+iwrite+8
1928  endif
1929 
1930 !var real8
1931  if (gfile%nmetavarr8.gt.0) then
1932  idisp=gfile%tlmeta
1933  iwrite=len(gfile%varr8name)*gfile%nmetavarr8
1934  nwrite=iwrite
1935  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1936  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1937  idisp=idisp+4
1938  call mpi_file_write_at(gfile%fh,idisp,gfile%varr8name,iwrite,mpi_character,status,ios)
1939  idisp=idisp+iwrite
1940  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1941  gfile%tlmeta=gfile%tlmeta+iwrite+8
1942 
1943  idisp=gfile%tlmeta
1944  iwrite=gfile%nmetavarr8
1945  nwrite=iwrite*kind(gfile%varr8val)
1946  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1947  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1948  idisp=idisp+4
1949  if(gfile%do_byteswap) &
1950  call byteswap(gfile%varr8val,nemsio_dblekind,size(gfile%varr8val))
1951  call mpi_file_write_at(gfile%fh,idisp,gfile%varr8val,iwrite,mpi_real8,status,ios)
1952  if(gfile%do_byteswap) &
1953  call byteswap(gfile%varr8val,nemsio_dblekind,size(gfile%varr8val))
1954  idisp=idisp+iwrite*kind(gfile%varr8val)
1955  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1956  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%varr8val)+8
1957  endif
1958 
1959 !meta arr integer
1960  if (gfile%nmetaaryi.gt.0) then
1961  idisp=gfile%tlmeta
1962  iwrite=len(gfile%aryiname)*gfile%nmetaaryi
1963  nwrite=iwrite
1964  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1965  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1966  idisp=idisp+4
1967  call mpi_file_write_at(gfile%fh,idisp,gfile%aryiname,iwrite,mpi_character,status,ios)
1968  idisp=idisp+iwrite
1969  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1970  gfile%tlmeta=gfile%tlmeta+iwrite+8
1971 
1972  idisp=gfile%tlmeta
1973  iwrite=gfile%nmetaaryi
1974  nwrite=iwrite*kind(gfile%aryilen)
1975  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1976  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1977  idisp=idisp+4
1978  if(gfile%do_byteswap) &
1979  call byteswap(gfile%aryilen,nemsio_intkind,size(gfile%aryilen))
1980  call mpi_file_write_at(gfile%fh,idisp,gfile%aryilen,iwrite,mpi_integer,status,ios)
1981  if(gfile%do_byteswap) &
1982  call byteswap(gfile%aryilen,nemsio_intkind,size(gfile%aryilen))
1983  idisp=idisp+iwrite*kind(gfile%aryilen)
1984  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1985  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryilen)+8
1986 !
1987  do i=1,gfile%nmetaaryi
1988  idisp=gfile%tlmeta
1989  iwrite=gfile%aryilen(i)
1990  nwrite=iwrite*kind(gfile%aryival)
1991  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
1992  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
1993  idisp=idisp+4
1994  if(gfile%do_byteswap) &
1995  call byteswap(gfile%aryival(1:iwrite,i),nemsio_intkind,gfile%aryilen(i))
1996  call mpi_file_write_at(gfile%fh,idisp,gfile%aryival(1:iwrite,i),iwrite,mpi_integer,status,ios)
1997  if(gfile%do_byteswap) &
1998  call byteswap(gfile%aryival(1:iwrite,i),nemsio_intkind,gfile%aryilen(i))
1999  idisp=idisp+iwrite*kind(gfile%aryival)
2000  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2001  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryival)+8
2002  enddo
2003  endif
2004 !meta arr real
2005  if (gfile%nmetaaryr.gt.0) then
2006  idisp=gfile%tlmeta
2007  iwrite=len(gfile%aryrname)*gfile%nmetaaryr
2008  nwrite=iwrite
2009  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2010  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2011  idisp=idisp+4
2012  call mpi_file_write_at(gfile%fh,idisp,gfile%aryrname,iwrite,mpi_character,status,ios)
2013  idisp=idisp+iwrite
2014  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2015  gfile%tlmeta=gfile%tlmeta+iwrite+8
2016 
2017  idisp=gfile%tlmeta
2018  iwrite=gfile%nmetaaryr
2019  nwrite=iwrite*kind(gfile%aryrlen)
2020  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2021  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2022  idisp=idisp+4
2023  if(gfile%do_byteswap) &
2024  call byteswap(gfile%aryrlen,nemsio_intkind,size(gfile%aryrlen))
2025  call mpi_file_write_at(gfile%fh,idisp,gfile%aryrlen,iwrite,mpi_integer,status,ios)
2026  if(gfile%do_byteswap) &
2027  call byteswap(gfile%aryrlen,nemsio_intkind,size(gfile%aryrlen))
2028  idisp=idisp+iwrite*kind(gfile%aryrlen)
2029  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2030  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryrlen)+8
2031 !
2032  do i=1,gfile%nmetaaryr
2033  idisp=gfile%tlmeta
2034  iwrite=gfile%aryrlen(i)
2035  nwrite=iwrite*kind(gfile%aryrval)
2036  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2037  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2038  idisp=idisp+4
2039  if(gfile%do_byteswap) &
2040  call byteswap(gfile%aryrval(1:iwrite,i),nemsio_realkind,gfile%aryrlen(i))
2041  call mpi_file_write_at(gfile%fh,idisp,gfile%aryrval(1:iwrite,i),iwrite,mpi_real,status,ios)
2042  if(gfile%do_byteswap) &
2043  call byteswap(gfile%aryrval(1:iwrite,i),nemsio_realkind,gfile%aryrlen(i))
2044  idisp=idisp+iwrite*kind(gfile%aryrval)
2045  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2046  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryrval)+8
2047  enddo
2048  endif
2049 !meta arr logical
2050  if (gfile%nmetaaryl.gt.0) then
2051  idisp=gfile%tlmeta
2052  iwrite=len(gfile%arylname)*gfile%nmetaaryl
2053  nwrite=iwrite
2054  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2055  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2056  idisp=idisp+4
2057  call mpi_file_write_at(gfile%fh,idisp,gfile%arylname,iwrite,mpi_character,status,ios)
2058  idisp=idisp+iwrite
2059  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2060  gfile%tlmeta=gfile%tlmeta+iwrite+8
2061 
2062  idisp=gfile%tlmeta
2063  iwrite=gfile%nmetaaryl
2064  nwrite=iwrite*kind(gfile%aryllen)
2065  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2066  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2067  idisp=idisp+4
2068  if(gfile%do_byteswap) &
2069  call byteswap(gfile%aryllen,nemsio_intkind,size(gfile%aryllen))
2070  call mpi_file_write_at(gfile%fh,idisp,gfile%aryllen,iwrite,mpi_integer,status,ios)
2071  if(gfile%do_byteswap) &
2072  call byteswap(gfile%aryllen,nemsio_intkind,size(gfile%aryllen))
2073  idisp=idisp+iwrite*kind(gfile%aryllen)
2074  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2075  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryllen)+8
2076 
2077  do i=1,gfile%nmetaaryl
2078  idisp=gfile%tlmeta
2079  iwrite=gfile%aryllen(i)
2080  nwrite=iwrite*kind(gfile%arylval)
2081  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2082  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2083  idisp=idisp+4
2084  if(gfile%do_byteswap) &
2085  call byteswap(gfile%arylval(1:iwrite,i),nemsio_logickind,gfile%aryllen(i))
2086  call mpi_file_write_at(gfile%fh,idisp,gfile%arylval(1:iwrite,i),iwrite,mpi_logical,status,ios)
2087  if(gfile%do_byteswap) &
2088  call byteswap(gfile%arylval(1:iwrite,i),nemsio_logickind,gfile%aryllen(i))
2089  idisp=idisp+iwrite*kind(gfile%arylval)
2090  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2091  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%arylval)+8
2092  enddo
2093  endif
2094 !meta arr char
2095  if (gfile%nmetaaryc.gt.0) then
2096  idisp=gfile%tlmeta
2097  iwrite=len(gfile%arycname)*gfile%nmetaaryc
2098  nwrite=iwrite
2099  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2100  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2101  idisp=idisp+4
2102  call mpi_file_write_at(gfile%fh,idisp,gfile%arycname,iwrite,mpi_character,status,ios)
2103  idisp=idisp+iwrite
2104  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2105  gfile%tlmeta=gfile%tlmeta+iwrite+8
2106 
2107  idisp=gfile%tlmeta
2108  iwrite=gfile%nmetaaryc
2109  nwrite=iwrite*kind(gfile%aryclen)
2110  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2111  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2112  idisp=idisp+4
2113  if(gfile%do_byteswap) &
2114  call byteswap(gfile%aryclen,nemsio_intkind,size(gfile%aryclen))
2115  call mpi_file_write_at(gfile%fh,idisp,gfile%aryclen,iwrite,mpi_integer,status,ios)
2116  if(gfile%do_byteswap) &
2117  call byteswap(gfile%aryclen,nemsio_intkind,size(gfile%aryclen))
2118  idisp=idisp+iwrite*kind(gfile%aryclen)
2119  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2120  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryclen)+8
2121 
2122  do i=1,gfile%nmetaaryc
2123  idisp=gfile%tlmeta
2124  iwrite=gfile%aryclen(i)*len(gfile%arycval)
2125  nwrite=iwrite
2126  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2127  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2128  idisp=idisp+4
2129  call mpi_file_write_at(gfile%fh,idisp,gfile%arycval(1:iwrite,i),iwrite,mpi_character,status,ios)
2130  idisp=idisp+iwrite
2131  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2132  gfile%tlmeta=gfile%tlmeta+iwrite+8
2133  enddo
2134  endif
2135 !meta arr real8
2136  if (gfile%nmetaaryr8.gt.0) then
2137  idisp=gfile%tlmeta
2138  iwrite=len(gfile%aryr8name)*gfile%nmetaaryr8
2139  nwrite=iwrite
2140  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2141  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2142  idisp=idisp+4
2143  call mpi_file_write_at(gfile%fh,idisp,gfile%aryr8name,iwrite,mpi_character,status,ios)
2144  idisp=idisp+iwrite
2145  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2146  gfile%tlmeta=gfile%tlmeta+iwrite+8
2147 
2148  idisp=gfile%tlmeta
2149  iwrite=gfile%nmetaaryr8
2150  nwrite=iwrite*kind(gfile%aryr8len)
2151  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2152  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2153  idisp=idisp+4
2154  if(gfile%do_byteswap) &
2155  call byteswap(gfile%aryr8len,nemsio_intkind,size(gfile%aryr8len))
2156  call mpi_file_write_at(gfile%fh,idisp,gfile%aryr8len,iwrite,mpi_integer,status,ios)
2157  if(gfile%do_byteswap) &
2158  call byteswap(gfile%aryr8len,nemsio_intkind,size(gfile%aryr8len))
2159  idisp=idisp+iwrite*kind(gfile%aryr8len)
2160  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2161  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryr8len)+8
2162 
2163  do i=1,gfile%nmetaaryr8
2164  idisp=gfile%tlmeta
2165  iwrite=gfile%aryr8len(i)
2166  nwrite=iwrite*kind(gfile%aryr8val)
2167  if(gfile%do_byteswap) call byteswap(nwrite,nemsio_intkind,1)
2168  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2169  idisp=idisp+4
2170  if(gfile%do_byteswap) &
2171  call byteswap(gfile%aryr8val(1:iwrite,i),nemsio_dblekind,gfile%aryr8len(i))
2172  call mpi_file_write_at(gfile%fh,idisp,gfile%aryr8val(1:iwrite,i),iwrite,mpi_real8,status,ios)
2173  if(gfile%do_byteswap) &
2174  call byteswap(gfile%aryr8val(1:iwrite,i),nemsio_dblekind,gfile%aryr8len(i))
2175  idisp=idisp+iwrite*kind(gfile%aryr8val)
2176  call mpi_file_write_at(gfile%fh,idisp,nwrite,1,mpi_integer,status,ios)
2177  gfile%tlmeta=gfile%tlmeta+iwrite*kind(gfile%aryr8val)+8
2178  enddo
2179  endif
2180 
2181  endif !end of gfile%extrameta
2182 !
2183  endif !end of lead_task
2184 !mpi
2185  call mpi_barrier(gfile%mpi_comm, ios)
2186  call mpi_bcast(gfile%tlmeta,1,mpi_integer8,gfile%lead_task,gfile%mpi_comm,ios)
2187 ! write(0,*)'after mpi_bcasttlmeta,',gfile%tlmeta, 'end of wcreate,ios=',ios
2188 !
2189  iret=0
2190 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2191  end subroutine nemsio_wcreate
2192 !------------------------------------------------------------------------------
2193  subroutine nemsio_getfilehead(gfile,iret,gtype,gdatatype,gfname,gaction, &
2194  modelname,version,nmeta,lmeta,nrec,idate,nfday,nfhour,nfminute, &
2195  nfsecondn,nfsecondd,dimx,dimy,dimz,nframe,nsoil,ntrac,ncldt,jcap,&
2196  idvc,idsl,idvm,idrt, rlon_min,rlon_max,rlat_min,rlat_max,tlmeta, &
2197  file_endian,do_byteswap, &
2198  extrameta,nmetavari,nmetavarr,nmetavarl,nmetavarc,nmetavarr8, &
2199  nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc,nmetaaryr8, &
2200  recname,reclevtyp,reclev,vcoord,lon,lat,dx,dy,cpi,ri, &
2201  variname,varival,varrname,varrval,varlname,varlval,varcname,varcval, &
2202  varr8name,varr8val, &
2203  aryiname,aryilen,aryival,aryrname,aryrlen,aryrval, &
2204  arylname,aryllen,arylval,arycname,aryclen,arycval, &
2205  aryr8name,aryr8len,aryr8val )
2206 
2207 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2208 ! abstract: get nemsio meta data information from outside
2209 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2210  implicit none
2211  type(nemsio_gfile),intent(in) :: gfile
2212  integer(nemsio_intkind),optional,intent(out) :: iret
2213  character*(*),optional,intent(out) :: gtype,gdatatype,gfname, &
2214  gaction,modelname
2215  integer(nemsio_intkind),optional,intent(out) :: version,nmeta,lmeta,tlmeta
2216  integer(nemsio_realkind),optional,intent(out):: nrec,idate(7),nfday,nfhour, &
2217  nfminute,nfsecondn,nfsecondd
2218  integer(nemsio_realkind),optional,intent(out):: dimx,dimy,dimz,nframe, &
2219  nsoil,ntrac
2220  integer(nemsio_realkind),optional,intent(out):: ncldt,jcap,idvc,idsl,idvm,idrt
2221  real(nemsio_realkind),optional,intent(out) :: rlon_min,rlon_max,rlat_min, &
2222  rlat_max
2223  character*(*),optional,intent(out) :: file_endian
2224  logical(nemsio_logickind),optional,intent(out):: do_byteswap
2225  logical(nemsio_logickind),optional,intent(out):: extrameta
2226  integer(nemsio_realkind),optional,intent(out):: nmetavari,nmetavarr, &
2227  nmetavarl,nmetavarc,nmetaaryi, &
2228  nmetaaryr,nmetaaryl,nmetaaryc, &
2229  nmetavarr8,nmetaaryr8
2230  character(*),optional,intent(out) :: recname(:)
2231  character(*),optional,intent(out) :: reclevtyp(:)
2232  integer(nemsio_intkind),optional,intent(out) :: reclev(:)
2233  real(nemsio_realkind),optional,intent(out) :: vcoord(:,:,:)
2234  real(nemsio_realkind),optional,intent(out) :: lat(:),lon(:)
2235  real(nemsio_realkind),optional,intent(out) :: dx(:),dy(:)
2236  real(nemsio_realkind),optional,intent(out) :: Cpi(:),Ri(:)
2237  character(*),optional,intent(out) :: variname(:),varrname(:)
2238  character(*),optional,intent(out) :: varlname(:),varcname(:)
2239  character(*),optional,intent(out) :: varr8name(:)
2240  character(*),optional,intent(out) :: aryiname(:),aryrname(:)
2241  character(*),optional,intent(out) :: arylname(:),arycname(:)
2242  character(*),optional,intent(out) :: aryr8name(:)
2243  integer(nemsio_intkind),optional,intent(out) :: aryilen(:),aryrlen(:)
2244  integer(nemsio_intkind),optional,intent(out) :: aryllen(:),aryclen(:)
2245  integer(nemsio_intkind),optional,intent(out) :: aryr8len(:)
2246  integer(nemsio_intkind),optional,intent(out) :: varival(:),aryival(:,:)
2247  real(nemsio_realkind),optional,intent(out) :: varrval(:),aryrval(:,:)
2248  real(nemsio_dblekind),optional,intent(out) :: varr8val(:),aryr8val(:,:)
2249  logical(nemsio_logickind),optional,intent(out):: varlval(:),arylval(:,:)
2250  character(*),optional,intent(out) :: varcval(:),arycval(:,:)
2251  integer ios,i
2252 !------------------------------------------------------------
2253  if (present(iret)) iret=-3
2254  if(present(gtype)) gtype=gfile%gtype
2255  if(present(gdatatype)) gdatatype=gfile%gdatatype
2256  if(present(gfname)) gfname=trim(gfile%gfname)
2257  if(present(gaction)) gaction=gfile%gaction
2258  if(present(modelname)) modelname=gfile%modelname
2259  if(present(version)) version=gfile%version
2260  if(present(nmeta)) nmeta=gfile%nmeta
2261  if(present(lmeta)) lmeta=gfile%lmeta
2262  if(present(nrec)) nrec=gfile%nrec
2263  if(present(nfday)) nfday=gfile%nfday
2264  if(present(nfhour)) nfhour=gfile%nfhour
2265  if(present(nfminute)) nfminute=gfile%nfminute
2266  if(present(nfsecondn)) nfsecondn=gfile%nfsecondn
2267  if(present(nfsecondd)) nfsecondd=gfile%nfsecondd
2268  if(present(idate)) idate(1:7)=gfile%idate(1:7)
2269  if(present(dimx)) dimx=gfile%dimx
2270  if(present(dimy)) dimy=gfile%dimy
2271  if(present(dimz)) dimz=gfile%dimz
2272  if(present(nframe)) nframe=gfile%nframe
2273  if(present(nsoil)) nsoil=gfile%nsoil
2274  if(present(ntrac)) ntrac=gfile%ntrac
2275  if(present(jcap)) jcap=gfile%jcap
2276  if(present(ncldt)) ncldt=gfile%ncldt
2277  if(present(idvc)) idvc=gfile%idvc
2278  if(present(idsl)) idsl=gfile%idsl
2279  if(present(idvm)) idvm=gfile%idvm
2280  if(present(idrt)) idrt=gfile%idrt
2281  if(present(rlon_min)) rlon_min=gfile%rlon_min
2282  if(present(rlon_max)) rlon_max=gfile%rlon_max
2283  if(present(rlat_min)) rlat_min=gfile%rlat_min
2284  if(present(rlat_max)) rlat_max=gfile%rlat_max
2285  if(present(rlat_max)) rlat_max=gfile%rlat_max
2286  if(present(tlmeta)) tlmeta=gfile%tlmeta
2287  if(present(file_endian)) file_endian=gfile%file_endian
2288  if(present(do_byteswap)) do_byteswap=gfile%do_byteswap
2289  if(present(extrameta)) extrameta=gfile%extrameta
2290 !
2291 ! print *,'in getfilehead, 1extrameta=',gfile%extrameta, &
2292 ! 'nrec=',gfile%nrec,'size(recname)=',size(recname), &
2293 ! size(reclevtyp),size(reclev)
2294 !--- rec
2295  if(present(recname) ) then
2296  if (gfile%nrec.ne.size(recname)) then
2297  if ( present(iret)) return
2298  call nemsio_stop
2299  else
2300  recname=gfile%recname
2301  endif
2302  endif
2303  if(present(reclevtyp)) then
2304  if (gfile%nrec.ne.size(reclevtyp)) then
2305  if ( present(iret)) return
2306  call nemsio_stop
2307  else
2308  reclevtyp=gfile%reclevtyp
2309  endif
2310  endif
2311  if(present(reclev) ) then
2312  if (gfile%nrec.ne.size(reclev)) then
2313  if ( present(iret)) return
2314  call nemsio_stop
2315  else
2316  reclev=gfile%reclev
2317  endif
2318  endif
2319 !--- vcoord
2320  if(present(vcoord)) then
2321  if (size(vcoord) .ne. (gfile%dimz+1)*2*3 ) then
2322  if ( present(iret)) return
2323  call nemsio_stop
2324  else
2325  vcoord=gfile%vcoord
2326  endif
2327  endif
2328 !--- lat
2329  if(present(lat) ) then
2330  if (size(lat).ne.gfile%fieldsize) then
2331  print *,'WRONG: size(lat)=',size(lat),' is not equal to ',gfile%fieldsize
2332  if ( present(iret)) return
2333  call nemsio_stop
2334  else
2335  lat=gfile%lat
2336  endif
2337  endif
2338 !--- lon
2339  if(present(lon) ) then
2340  if (size(lon).ne.gfile%fieldsize) then
2341  print *,'WRONG: size(lon)=',size(lon),' is not equal to ',gfile%fieldsize
2342  if ( present(iret)) return
2343  call nemsio_stop
2344  else
2345  lon=gfile%lon
2346  endif
2347  endif
2348 !--- dx
2349  if(present(dx) ) then
2350 ! print *,'getfilehead, size(dx)=',size(dx),gfile%fieldsize, &
2351 ! maxval(gfile%dx),minval(gfile%dx)
2352  if (size(dx).ne.gfile%fieldsize) then
2353  print *,'WRONG: size(dX)=',size(dx),' is not equal to ',gfile%fieldsize
2354  if ( present(iret)) return
2355  call nemsio_stop
2356  else
2357  dx=gfile%dx
2358  endif
2359  endif
2360  if(present(dy) ) then
2361  if (size(dy).ne.gfile%fieldsize) then
2362  print *,'WRONG: size(dy)=',size(dy),' is not equal to ',gfile%fieldsize
2363  if ( present(iret)) return
2364  call nemsio_stop
2365  else
2366  dy=gfile%dy
2367  endif
2368  endif
2369 !--- Cpi
2370  if(present(cpi) ) then
2371  if (gfile%ntrac+1.ne.size(cpi)) then
2372  if ( present(iret)) return
2373  call nemsio_stop
2374  else
2375  cpi=gfile%Cpi
2376  endif
2377  endif
2378 !Ri
2379  if(present(ri) ) then
2380  if (gfile%ntrac+1.ne.size(ri)) then
2381  if ( present(iret)) return
2382  call nemsio_stop
2383  else
2384  ri=gfile%Ri
2385  endif
2386  endif
2387 !------------------------------------------------------------------------------
2388 !*** for extra meta field
2389 !------------------------------------------------------------------------------
2390 !extrameta
2391  if (present(nmetavari) ) nmetavari=gfile%nmetavari
2392  if (present(nmetavarr) ) nmetavarr=gfile%nmetavarr
2393  if (present(nmetavarl) ) nmetavarl=gfile%nmetavarl
2394  if (present(nmetavarc) ) nmetavarc=gfile%nmetavarc
2395  if (present(nmetavarr8) ) nmetavarr8=gfile%nmetavarr8
2396  if (present(nmetaaryi) ) nmetaaryi=gfile%nmetaaryi
2397  if (present(nmetaaryr) ) nmetaaryr=gfile%nmetaaryr
2398  if (present(nmetaaryl) ) nmetaaryl=gfile%nmetaaryl
2399  if (present(nmetaaryc) ) nmetaaryc=gfile%nmetaaryc
2400  if (present(nmetaaryr8) ) nmetaaryr8=gfile%nmetaaryr8
2401  if ( gfile%nmetavari.gt.0 ) then
2402  if (present(variname)) then
2403  if(size(variname).eq.nmetavari) then
2404  do i=1,nmetavari
2405  variname(i)=gfile%variname(i)
2406  enddo
2407  endif
2408  endif
2409  if (present(varival)) then
2410  if(size(varival).eq.nmetavari) varival(1:nmetavari)=gfile%varival(1:nmetavari)
2411  endif
2412  endif
2413  if ( gfile%nmetavarr.gt.0 ) then
2414  if (present(varrname)) then
2415  if(size(varrname).eq.nmetavarr) varrname=gfile%varrname
2416  endif
2417  if (present(varrval)) then
2418  if(size(varrval).eq.nmetavarr) varrval=gfile%varrval
2419  endif
2420  endif
2421  if ( gfile%nmetavarl.gt.0 ) then
2422  if (present(varlname)) then
2423  if(size(varlname).eq.nmetavarl) varlname=gfile%varlname
2424  endif
2425  if (present(varlval)) then
2426  if(size(varlval).eq.nmetavarl) varlval=gfile%varlval
2427  endif
2428  endif
2429  if ( gfile%nmetavarc.gt.0 ) then
2430  if (present(varcname)) then
2431  if(size(varcname).eq.gfile%nmetavarc) varcname=gfile%varcname
2432  endif
2433  if (present(varcval)) then
2434  if(size(varcval).eq.gfile%nmetavarc) varcval=gfile%varcval
2435  endif
2436  endif
2437  if ( gfile%nmetavarr8.gt.0 ) then
2438  if (present(varr8name)) then
2439  if(size(varr8name).eq.gfile%nmetavarr8) varr8name=gfile%varr8name
2440  endif
2441  if (present(varr8val)) then
2442  if(size(varr8val).eq.gfile%nmetavarr8) varr8val=gfile%varr8val
2443  endif
2444  endif
2445  if ( gfile%nmetaaryi.gt.0 ) then
2446  if (present(aryiname)) then
2447  if(size(aryiname).eq.nmetaaryi) aryiname=gfile%aryiname
2448  endif
2449  if (present(aryilen)) then
2450  if(size(aryilen).eq.nmetaaryi) aryilen=gfile%aryilen
2451  endif
2452  if (present(aryival)) then
2453  if(size(aryival).eq.nmetaaryi*maxval(gfile%aryilen) ) &
2454  aryival=gfile%aryival
2455  endif
2456  endif
2457  if ( gfile%nmetaaryr.gt.0 ) then
2458  if (present(aryrname)) then
2459  if(size(aryrname).eq.nmetaaryr) aryrname=gfile%aryrname
2460  endif
2461  if (present(aryrlen)) then
2462  if(size(aryrlen).eq.nmetaaryr) aryrlen=gfile%aryrlen
2463  endif
2464  if (present(aryrval)) then
2465  if(size(aryrval).eq.nmetaaryr*maxval(gfile%aryrlen) ) &
2466  aryrval=gfile%aryrval
2467  endif
2468  endif
2469  if ( gfile%nmetaaryl.gt.0 ) then
2470  if (present(arylname)) then
2471  if(size(arylname).eq.nmetaaryl) arylname=gfile%arylname
2472  endif
2473  if (present(aryllen)) then
2474  if(size(aryllen).eq.nmetaaryl) aryllen=gfile%aryllen
2475  endif
2476  if (present(arylval) ) then
2477  if(size(arylval).eq.nmetaaryl*maxval(gfile%aryllen) ) &
2478  arylval=gfile%arylval
2479  endif
2480  endif
2481  if ( gfile%nmetaaryc.gt.0 ) then
2482  if (present(arycname)) then
2483  if(size(arycname).eq.gfile%nmetaaryc) arycname=gfile%arycname
2484  endif
2485  if (present(aryclen)) then
2486  if(size(aryclen).eq.gfile%nmetaaryc) aryclen=gfile%aryclen
2487  endif
2488  if (present(arycval)) then
2489  if(size(arycval).eq.gfile%nmetaaryc*maxval(gfile%aryclen) ) &
2490  arycval=gfile%arycval
2491  endif
2492  endif
2493  if ( gfile%nmetaaryr8.gt.0 ) then
2494  if (present(aryr8name)) then
2495  if( size(aryr8name).eq.gfile%nmetaaryr8) aryr8name=gfile%aryr8name
2496  endif
2497  if (present(aryr8len)) then
2498  if(size(aryr8len).eq.gfile%nmetaaryr8) aryr8len=gfile%aryr8len
2499  endif
2500  if (present(aryr8val)) then
2501  if(size(aryr8val).eq.gfile%nmetaaryr8*maxval(gfile%aryr8len) ) &
2502  aryr8val=gfile%aryr8val
2503  endif
2504  endif
2505 
2506  call mpi_barrier(gfile%mpi_comm,ios)
2507  if ( present(iret)) iret=0
2508 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2509  end subroutine nemsio_getfilehead
2510 !------------------------------------------------------------------------------
2511  subroutine nemsio_getfheadvari(gfile,varname,varval,iret)
2512 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2513 ! abstract: get meta data var value from file header
2514 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2515  implicit none
2516  type(nemsio_gfile),intent(in) :: gfile
2517  character(*), intent(in) :: varname
2518  integer(nemsio_intkind),intent(out) :: varval
2519  integer(nemsio_intkind),optional,intent(out) :: iret
2520  integer i,j
2521 !---
2522  if(present(iret) ) iret=-17
2523  do i=1,gfile%headvarinum
2524  if(equal_str_nocase(trim(varname),trim(gfile%headvariname(i))) ) then
2525  varval=gfile%headvarival(i)
2526  if(present(iret) ) iret=0
2527  return
2528  endif
2529  enddo
2530 !---
2531  if(gfile%nmetavari.gt.0) then
2532  do i=1,gfile%nmetavari
2533  if(equal_str_nocase(trim(varname),trim(gfile%variname(i))) ) then
2534  varval=gfile%varival(i)
2535  if(present(iret) ) iret=0
2536  return
2537  endif
2538  enddo
2539  endif
2540 !---
2541  if(.not.present(iret) ) call nemsio_stop
2542  return
2543  end subroutine nemsio_getfheadvari
2544 !------------------------------------------------------------------------------
2545  subroutine nemsio_getfheadvarr(gfile,varname,varval,iret)
2546 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2547 ! abstract: get meta data var value from file header
2548 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2549  implicit none
2550  type(nemsio_gfile),intent(in) :: gfile
2551  character(*), intent(in) :: varname
2552  real(nemsio_realkind),intent(out) :: varval
2553  integer(nemsio_intkind),optional,intent(out) :: iret
2554  integer i,j
2555 !---
2556  if(present(iret) ) iret=-17
2557  do i=1,gfile%headvarrnum
2558  if(equal_str_nocase(trim(varname),trim(gfile%headvarrname(i))) ) then
2559  varval=gfile%headvarrval(i)
2560  if(present(iret) ) iret=0
2561  return
2562  endif
2563  enddo
2564 !---
2565  if(gfile%nmetavarr.gt.0) then
2566  do i=1,gfile%nmetavarr
2567  if(equal_str_nocase(trim(varname),trim(gfile%varrname(i))) ) then
2568  varval=gfile%varrval(i)
2569  if(present(iret) ) iret=0
2570  return
2571  endif
2572  enddo
2573  endif
2574 !---
2575  if(.not.present(iret) ) call nemsio_stop
2576  return
2577  end subroutine nemsio_getfheadvarr
2578 !------------------------------------------------------------------------------
2579  subroutine nemsio_getfheadvarl(gfile,varname,varval,iret)
2580 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2581 ! abstract: get meta data var value from file header
2582 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2583  implicit none
2584  type(nemsio_gfile),intent(in) :: gfile
2585  character(*), intent(in) :: varname
2586  logical(nemsio_logickind),intent(out) :: varval
2587  integer(nemsio_intkind),optional,intent(out) :: iret
2588  integer i,j
2589 !---
2590  if(present(iret) ) iret=-17
2591  if(gfile%nmetavarl.gt.0) then
2592  do i=1,gfile%nmetavarl
2593  if(equal_str_nocase(trim(varname),trim(gfile%varlname(i))) ) then
2594  varval=gfile%varlval(i)
2595  if(present(iret) ) iret=0
2596  return
2597  endif
2598  enddo
2599  endif
2600 !---
2601  if(.not.present(iret) ) call nemsio_stop
2602  return
2603  end subroutine nemsio_getfheadvarl
2604 !------------------------------------------------------------------------------
2605  subroutine nemsio_getfheadvarc(gfile,varname,varval,iret)
2606 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2607 ! abstract: get meta data var value from file header
2608 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2609  implicit none
2610  type(nemsio_gfile),intent(in) :: gfile
2611  character(*), intent(in) :: varname
2612  character(*),intent(out) :: varval
2613  integer(nemsio_intkind),optional,intent(out) :: iret
2614  integer i,j
2615 !---
2616  if(present(iret) ) iret=-17
2617  do i=1,gfile%headvarcnum
2618  if(equal_str_nocase(trim(varname),trim(gfile%headvarcname(i))) ) then
2619  varval=gfile%headvarcval(i)
2620  if(present(iret) ) iret=0
2621  return
2622  endif
2623  enddo
2624 !---
2625  if(gfile%nmetavarc.gt.0) then
2626  do i=1,gfile%nmetavarc
2627  if(equal_str_nocase(trim(varname),trim(gfile%varcname(i))) ) then
2628  varval=gfile%varcval(i)
2629  if(present(iret) ) iret=0
2630  return
2631  endif
2632  enddo
2633  endif
2634 !---
2635  if(.not.present(iret) ) call nemsio_stop
2636  return
2637  end subroutine nemsio_getfheadvarc
2638 !------------------------------------------------------------------------------
2639  subroutine nemsio_getfheadvarr8(gfile,varname,varval,iret)
2640 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2641 ! abstract: get meta data var value from file header
2642 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2643  implicit none
2644  type(nemsio_gfile),intent(in) :: gfile
2645  character(len=*), intent(in) :: varname
2646  real(nemsio_dblekind),intent(out) :: varval
2647  integer(nemsio_intkind),optional,intent(out) :: iret
2648  integer i,j
2649 !---
2650  if(present(iret) ) iret=-17
2651 !---
2652  if(gfile%nmetavarr8.gt.0) then
2653  do i=1,gfile%nmetavarr8
2654  if(equal_str_nocase(trim(varname),trim(gfile%varr8name(i))) ) then
2655  varval=gfile%varr8val(i)
2656  if(present(iret) ) iret=0
2657  return
2658  endif
2659  enddo
2660  endif
2661 
2662  if(.not.present(iret) ) call nemsio_stop
2663  return
2664  end subroutine nemsio_getfheadvarr8
2665 !------------------------------------------------------------------------------
2666  subroutine nemsio_getfheadaryi(gfile,varname,varval,iret)
2667 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2668 ! abstract: get meta data var value from file header
2669 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2670  implicit none
2671  type(nemsio_gfile),intent(in) :: gfile
2672  character(*), intent(in) :: varname
2673  integer(nemsio_intkind),intent(out) :: varval(:)
2674  integer(nemsio_intkind),optional,intent(out) :: iret
2675  integer i,j,ios
2676 !---
2677  if(present(iret) ) iret=-17
2678  do i=1,gfile%headaryinum
2679  if(equal_str_nocase(trim(varname),trim(gfile%headaryiname(i))) ) then
2680  varval(:)=gfile%headaryival(1:gfile%aryilen(i),i)
2681  if(present(iret) ) iret=0
2682  return
2683  endif
2684  enddo
2685 !---
2686  if(gfile%nmetaaryi.gt.0) then
2687  do i=1,gfile%nmetaaryi
2688  if(equal_str_nocase(trim(varname),trim(gfile%aryiname(i))) ) then
2689  varval(:)=gfile%aryival(1:gfile%aryilen(i),i)
2690  if(present(iret) ) iret=0
2691  ios=0
2692  return
2693  endif
2694  enddo
2695  endif
2696 !---
2697  if(.not.present(iret) ) call nemsio_stop
2698  return
2699  end subroutine nemsio_getfheadaryi
2700 !------------------------------------------------------------------------------
2701  subroutine nemsio_getfheadaryr(gfile,varname,varval,iret)
2702 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2703 ! abstract: get meta data var value from file header
2704 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2705  implicit none
2706  type(nemsio_gfile),intent(in) :: gfile
2707  character(*), intent(in) :: varname
2708  real(nemsio_realkind),intent(out) :: varval(:)
2709  integer(nemsio_intkind),optional,intent(out) :: iret
2710  integer i,j,ios
2711 !---
2712  if(present(iret) ) iret=-17
2713  if(gfile%headaryrnum>0) then
2714  do i=1,gfile%headaryrnum
2715  if(equal_str_nocase(trim(varname),trim(gfile%headaryrname(i))) ) then
2716  varval(:)=gfile%headaryrval(1:gfile%aryrlen(i),i)
2717  if(present(iret) ) iret=0
2718  return
2719  endif
2720  enddo
2721  endif
2722 !---
2723  if(gfile%nmetaaryr.gt.0) then
2724  do i=1,gfile%nmetaaryr
2725  if(equal_str_nocase(trim(varname),trim(gfile%aryrname(i)))) then
2726  varval(:)=gfile%aryrval(1:gfile%aryrlen(i),i)
2727  if(present(iret) ) iret=0
2728  ios=0
2729  return
2730  endif
2731  enddo
2732  endif
2733 !---
2734  if(.not.present(iret) ) call nemsio_stop
2735  return
2736  end subroutine nemsio_getfheadaryr
2737 !------------------------------------------------------------------------------
2738  subroutine nemsio_getfheadaryl(gfile,varname,varval,iret)
2739 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2740 ! abstract: get meta data var value from file header
2741 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2742  implicit none
2743  type(nemsio_gfile),intent(in) :: gfile
2744  character(*), intent(in) :: varname
2745  logical(nemsio_logickind),intent(out) :: varval(:)
2746  integer(nemsio_intkind),optional,intent(out) :: iret
2747  integer i,j,ios
2748 !---
2749  if(present(iret) ) iret=-17
2750  if(gfile%nmetaaryl.gt.0) then
2751  do i=1,gfile%nmetaaryl
2752  if(equal_str_nocase(trim(varname),trim(gfile%arylname(i)))) then
2753  varval(:)=gfile%arylval(1:gfile%aryllen(i),i)
2754  if(present(iret) ) iret=0
2755  ios=0
2756  return
2757  endif
2758  enddo
2759  endif
2760 !---
2761  if(.not.present(iret) ) call nemsio_stop
2762  return
2763  end subroutine nemsio_getfheadaryl
2764 !------------------------------------------------------------------------------
2765  subroutine nemsio_getfheadaryc(gfile,varname,varval,iret)
2766 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2767 ! abstract: get meta data var value from file header
2768 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2769  implicit none
2770  type(nemsio_gfile),intent(in) :: gfile
2771  character(*), intent(in) :: varname
2772  character(*),intent(out) :: varval(:)
2773  integer(nemsio_intkind),optional,intent(out) :: iret
2774  integer i,j,ios
2775 !---
2776  if(present(iret) ) iret=-17
2777  if(gfile%nmetaaryc.gt.0) then
2778  do i=1,gfile%nmetaaryc
2779  if(equal_str_nocase(trim(varname),trim(gfile%headarycname(i))) ) then
2780  varval(:)=gfile%headarycval(1:gfile%aryclen(i),i)
2781  if(present(iret) ) iret=0
2782  return
2783  endif
2784  enddo
2785  endif
2786 !---
2787  if(gfile%nmetaaryc.gt.0) then
2788  do i=1,gfile%nmetaaryc
2789  if(equal_str_nocase(trim(varname),trim(gfile%arycname(i)))) then
2790  varval(:)=gfile%arycval(1:gfile%aryclen(i),i)
2791  if(present(iret) ) iret=0
2792  ios=0
2793  return
2794  endif
2795  enddo
2796  endif
2797 !---
2798  if(.not.present(iret) ) call nemsio_stop
2799  return
2800  end subroutine nemsio_getfheadaryc
2801 !------------------------------------------------------------------------------
2802  subroutine nemsio_getfheadaryr8(gfile,varname,varval,iret)
2803 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2804 ! abstract: get meta data var value from file header
2805 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2806  implicit none
2807  type(nemsio_gfile),intent(in) :: gfile
2808  character(*), intent(in) :: varname
2809  real(nemsio_dblekind),intent(out) :: varval(:)
2810  integer(nemsio_intkind),optional,intent(out) :: iret
2811  integer i,j,ios
2812 !---
2813  if(present(iret) ) iret=-17
2814 !---
2815  if(gfile%nmetaaryr8.gt.0) then
2816  do i=1,gfile%nmetaaryr8
2817  if(equal_str_nocase(trim(varname),trim(gfile%aryr8name(i)))) then
2818  varval(:)=gfile%aryr8val(1:gfile%aryr8len(i),i)
2819  if(present(iret) ) iret=0
2820  ios=0
2821  return
2822  endif
2823  enddo
2824  endif
2825 !---
2826  if(.not.present(iret) ) call nemsio_stop
2827  return
2828  end subroutine nemsio_getfheadaryr8
2829 !------------------------------------------------------------------------------
2830 
2831 !***************** read bin data set : ********************************
2832 !
2833 !------------------------------------------------------------------------------
2834  subroutine nemsio_searchrecv(gfile,jrec,name,levtyp,lev,iret)
2835 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2836 ! abstract: search rec number giving rec name, levtyp and lev
2837 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2838  implicit none
2839  type(nemsio_gfile),intent(in) :: gfile
2840  integer(nemsio_intkind),intent(out) :: jrec
2841  character(*),intent(in) :: name, levtyp
2842  integer(nemsio_intkind),intent(in) :: lev
2843  integer(nemsio_intkind),optional,intent(out) :: iret
2844  integer i, nsize
2845 
2846  iret=-11
2847  jrec=0
2848  do i=1,gfile%nrec
2849  if ( trim(name) .eq. trim(gfile%recname(i)) .and. &
2850  trim(levtyp) .eq. trim(gfile%reclevtyp(i)) .and. &
2851  lev .eq. gfile%reclev(i) ) then
2852  jrec=i
2853  exit
2854  endif
2855  enddo
2856  if ( jrec .ne.0 ) iret=0
2857 !
2858  return
2859  end subroutine nemsio_searchrecv
2860 !------------------------------------------------------------------------------
2861 !
2862 !***************** no read grb1 data set : **********************************
2863 !
2864 !------------------------------------------------------------------------------
2865 !##############################################################################
2866 !
2867 !***************** write data set : ********************************
2868 !
2869 !##############################################################################
2870 !------------------------------------------------------------------------------
2871 
2872 !***************** write out bin data set : ********************************
2873 
2874 !------------------------------------------------------------------------------
2875 !
2876 !***************** no write out grb data set : ********************************
2877 !
2878 !------------------------------------------------------------------------------
2879 !------------------------------------------------------------------------------
2880  subroutine nemsio_chkgfary(gfile,iret)
2881 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2882 ! abstract: check if arrays in gfile is allocated and with right size
2883 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2884  implicit none
2885  type(nemsio_gfile),intent(inout) :: gfile
2886  integer(nemsio_intkind),intent(out) :: iret
2887  integer :: ios
2888 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2889  iret=-2
2890  if ( gfile%dimx .eq. nemsio_intfill .or. gfile%dimy .eq. nemsio_intfill &
2891  .or. gfile%dimz .eq. nemsio_intfill .or. gfile%nrec .eq. nemsio_intfill &
2892  .or. gfile%idate(1) .eq.nemsio_intfill .or. gfile%ntrac .eq.nemsio_intfill ) then
2893  return
2894  endif
2895  if (.not. allocated(gfile%vcoord) .or. size(gfile%vcoord).ne. &
2896  (gfile%dimz+1)*3*2 ) then
2897  call nemsio_almeta1(gfile,ios)
2898  if (ios .ne. 0) return
2899  endif
2900  if (.not.allocated(gfile%lat) .or. size(gfile%lat).ne.gfile%fieldsize .or.&
2901  .not.allocated(gfile%lon) .or. size(gfile%lon).ne.gfile%fieldsize .or.&
2902  .not.allocated(gfile%dx) .or. size(gfile%dx).ne.gfile%fieldsize .or.&
2903  .not.allocated(gfile%dy) .or. size(gfile%dy).ne.gfile%fieldsize) then
2904  call nemsio_almeta2(gfile,ios)
2905  if (ios .ne. 0) return
2906  endif
2907  if (.not.allocated(gfile%Cpi) .or. size(gfile%Cpi).ne.gfile%ntrac+1 .or. &
2908  .not.allocated(gfile%Ri) .or. size(gfile%Ri).ne.gfile%ntrac+1 ) then
2909  call nemsio_almeta3(gfile,ios)
2910  if (ios .ne. 0) return
2911  endif
2912 
2913  if (allocated(gfile%recname) .and. size(gfile%recname).eq.gfile%nrec)&
2914  then
2915  if (allocated(gfile%reclevtyp) .and. size(gfile%reclevtyp) &
2916  .eq.gfile%nrec) then
2917  if (allocated(gfile%reclev) .and. size(gfile%reclev).eq. &
2918  gfile%nrec) then
2919  iret=0
2920  return
2921  endif
2922  endif
2923  endif
2924  call nemsio_almeta4(gfile,ios)
2925  if (ios .ne. 0) return
2926  iret=0
2927  end subroutine nemsio_chkgfary
2928 !------------------------------------------------------------------------------
2929  subroutine nemsio_almeta(gfile,iret)
2930 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2931 ! abstract: allocate all the arrays in gfile
2932 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2933  implicit none
2934  type(nemsio_gfile),intent(inout) :: gfile
2935  integer(nemsio_intkind),intent(out) :: iret
2936  integer ::dimvcoord1,dimvcoord2,dimnmmlev
2937  integer ::dimrecname,dimreclevtyp,dimreclev
2938  integer ::dimfield
2939  integer ::dimcpr
2940  integer ::iret1,iret2,iret3,iret4
2941 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2942  dimvcoord1=gfile%dimz+1
2943  dimrecname=gfile%nrec
2944  dimreclevtyp=gfile%nrec
2945  dimreclev=gfile%nrec
2946  dimfield=gfile%fieldsize
2947  dimcpr=gfile%ntrac+1
2948  if(allocated(gfile%recname)) deallocate(gfile%recname)
2949  if(allocated(gfile%reclevtyp)) deallocate(gfile%reclevtyp)
2950  if(allocated(gfile%reclev)) deallocate(gfile%reclev)
2951  if(allocated(gfile%vcoord)) deallocate(gfile%vcoord)
2952  if(allocated(gfile%lat)) deallocate(gfile%lat)
2953  if(allocated(gfile%lon)) deallocate(gfile%lon)
2954  if(allocated(gfile%dx)) deallocate(gfile%dx)
2955  if(allocated(gfile%dy)) deallocate(gfile%dy)
2956  if(allocated(gfile%Cpi)) deallocate(gfile%Cpi)
2957  if(allocated(gfile%Ri)) deallocate(gfile%Ri)
2958  allocate(gfile%recname(dimrecname), gfile%reclevtyp(dimreclevtyp), &
2959  gfile%reclev(dimreclev), &
2960  stat=iret1)
2961  allocate(gfile%vcoord(dimvcoord1,3,2) ,stat=iret2)
2962  allocate(gfile%lat(dimfield), gfile%lon(dimfield), &
2963  gfile%dx(dimfield), gfile%dy(dimfield) ,stat=iret3)
2964  allocate(gfile%Cpi(dimcpr), gfile%Ri(dimcpr), stat=iret4)
2965 
2966  iret=abs(iret1)+abs(iret2)+abs(iret3)+abs(iret4)
2967  if(iret.eq.0) then
2968  gfile%reclev=nemsio_intfill
2969  gfile%recname=' '
2970  gfile%reclevtyp=' '
2971  gfile%vcoord=nemsio_realfill
2972  gfile%lat=nemsio_realfill
2973  gfile%lon=nemsio_realfill
2974  gfile%dx=nemsio_realfill
2975  gfile%dy=nemsio_realfill
2976  gfile%Cpi=nemsio_realfill
2977  gfile%Ri=nemsio_realfill
2978  endif
2979  if(iret.ne.0) iret=-6
2980  end subroutine nemsio_almeta
2981 !------------------------------------------------------------------------------
2982  subroutine nemsio_alextrameta(gfile,iret)
2983 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2984 ! abstract: allocate all the arrays in gfile
2985 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
2986  implicit none
2987  type(nemsio_gfile),intent(inout) :: gfile
2988  integer(nemsio_intkind),intent(out) :: iret
2989  integer ::iret1,iret2,iret3,iret4
2990 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2991  iret=-6
2992  if(gfile%extrameta) then
2993 ! print *,'nmetavari=',gfile%nmetavari,'nmetavarr=',gfile%nmetavarr, &
2994 ! 'nmetavarl=',gfile%nmetavarl,'nmetavarc=',gfile%nmetavarc, &
2995 ! 'nmetaaryi=',gfile%nmetaaryi,'nmetaaryr=',gfile%nmetaaryi, &
2996 ! 'nmetaaryl=',gfile%nmetaaryl,'nmetaaryc=',gfile%nmetaaryc
2997  if(gfile%nmetavari.gt.0) then
2998  if(allocated(gfile%variname)) deallocate(gfile%variname)
2999  if(allocated(gfile%varival)) deallocate(gfile%varival)
3000  allocate(gfile%variname(gfile%nmetavari), &
3001  gfile%varival(gfile%nmetavari), stat=iret1 )
3002  if(iret1.ne.0) return
3003  endif
3004  if(gfile%nmetavarr.gt.0) then
3005  if(allocated(gfile%varrname)) deallocate(gfile%varrname)
3006  if(allocated(gfile%varrval)) deallocate(gfile%varrval)
3007  allocate(gfile%varrname(gfile%nmetavarr), &
3008  gfile%varrval(gfile%nmetavarr), stat=iret1 )
3009  if(iret1.ne.0) return
3010  endif
3011  if(gfile%nmetavarl.gt.0) then
3012  if(allocated(gfile%varlname)) deallocate(gfile%varlname)
3013  if(allocated(gfile%varlval)) deallocate(gfile%varlval)
3014  allocate(gfile%varlname(gfile%nmetavarl), &
3015  gfile%varlval(gfile%nmetavarl), stat=iret1 )
3016  if(iret1.ne.0) return
3017  endif
3018  if(gfile%nmetavarc.gt.0) then
3019  if(allocated(gfile%varcname)) deallocate(gfile%varcname)
3020  if(allocated(gfile%varcval)) deallocate(gfile%varcval)
3021  allocate(gfile%varcname(gfile%nmetavarc), &
3022  gfile%varcval(gfile%nmetavarc), stat=iret1 )
3023  if(iret1.ne.0) return
3024  endif
3025  if(gfile%nmetavarr8.gt.0) then
3026  if(allocated(gfile%varr8name)) deallocate(gfile%varr8name)
3027  if(allocated(gfile%varr8val)) deallocate(gfile%varr8val)
3028  allocate(gfile%varr8name(gfile%nmetavarr8), &
3029  gfile%varr8val(gfile%nmetavarr8), stat=iret1 )
3030  if(iret1.ne.0) return
3031  endif
3032  if(gfile%nmetaaryi.gt.0) then
3033  if(allocated(gfile%aryiname)) deallocate(gfile%aryiname)
3034  if(allocated(gfile%aryilen)) deallocate(gfile%aryilen)
3035  if(allocated(gfile%aryival)) deallocate(gfile%aryival)
3036  allocate(gfile%aryiname(gfile%nmetaaryi), &
3037  gfile%aryilen(gfile%nmetaaryi), stat=iret1 )
3038  if(iret1.ne.0) return
3039  endif
3040  if(gfile%nmetaaryr.gt.0) then
3041  if(allocated(gfile%aryrname)) deallocate(gfile%aryrname)
3042  if(allocated(gfile%aryrlen)) deallocate(gfile%aryrlen)
3043  if(allocated(gfile%aryrval)) deallocate(gfile%aryrval)
3044  allocate(gfile%aryrname(gfile%nmetaaryr), &
3045  gfile%aryrlen(gfile%nmetaaryr), stat=iret1 )
3046  if(iret1.ne.0) return
3047  endif
3048  if(gfile%nmetaaryl.gt.0) then
3049  if(allocated(gfile%arylname)) deallocate(gfile%arylname)
3050  if(allocated(gfile%aryllen)) deallocate(gfile%aryllen)
3051  if(allocated(gfile%arylval)) deallocate(gfile%arylval)
3052  allocate(gfile%arylname(gfile%nmetaaryl), &
3053  gfile%aryllen(gfile%nmetaaryl), stat=iret1 )
3054  if(iret1.ne.0) return
3055  endif
3056  if(gfile%nmetaaryc.gt.0) then
3057  if(allocated(gfile%arycname)) deallocate(gfile%arycname)
3058  if(allocated(gfile%aryclen)) deallocate(gfile%aryclen)
3059  if(allocated(gfile%arycval)) deallocate(gfile%arycval)
3060  allocate(gfile%arycname(gfile%nmetaaryc), &
3061  gfile%aryclen(gfile%nmetaaryc), stat=iret1 )
3062  if(iret1.ne.0) return
3063  endif
3064  if(gfile%nmetaaryr8.gt.0) then
3065  if(allocated(gfile%aryr8name)) deallocate(gfile%aryr8name)
3066  if(allocated(gfile%aryr8len)) deallocate(gfile%aryr8len)
3067  if(allocated(gfile%aryr8val)) deallocate(gfile%aryr8val)
3068  allocate(gfile%aryr8name(gfile%nmetaaryr8), &
3069  gfile%aryr8len(gfile%nmetaaryr8), stat=iret1 )
3070  if(iret1.ne.0) return
3071  endif
3072  endif
3073 
3074  iret=0
3075  end subroutine nemsio_alextrameta
3076 !------------------------------------------------------------------------------
3077  subroutine nemsio_almeta1(gfile,iret)
3078 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3079 ! abstract: allocate vcoord in gfile
3080 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3081  implicit none
3082  type(nemsio_gfile),intent(inout) :: gfile
3083  integer(nemsio_intkind),intent(out) :: iret
3084  integer :: dimvcoord1,dimnmmlev,dimnmmnsoil
3085  integer :: dimgsilev
3086 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3087  dimvcoord1=gfile%dimz+1
3088  if(allocated(gfile%vcoord)) deallocate(gfile%vcoord)
3089  allocate(gfile%vcoord(dimvcoord1,3,2), stat=iret)
3090  if(iret.eq.0) then
3091  gfile%vcoord=nemsio_realfill
3092  endif
3093  if(iret.ne.0) iret=-6
3094  end subroutine nemsio_almeta1
3095 !------------------------------------------------------------------------------
3096  subroutine nemsio_almeta2(gfile,iret)
3097 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3098 ! abstract: allocate lat1d in gfile
3099 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3100  implicit none
3101  type(nemsio_gfile),intent(inout) :: gfile
3102  integer(nemsio_intkind),intent(out) :: iret
3103  integer :: dimlat
3104 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3105  dimlat=gfile%fieldsize
3106  if(allocated(gfile%lat)) deallocate(gfile%lat)
3107  if(allocated(gfile%lon)) deallocate(gfile%lon)
3108  if(allocated(gfile%dx)) deallocate(gfile%dx)
3109  if(allocated(gfile%dy)) deallocate(gfile%dy)
3110  allocate(gfile%lat(dimlat),gfile%lon(dimlat), &
3111  gfile%dx(dimlat),gfile%dy(dimlat), stat=iret)
3112  if(iret.eq.0) then
3113  gfile%lat=nemsio_realfill
3114  gfile%lon=nemsio_realfill
3115  gfile%dx=nemsio_realfill
3116  gfile%dy=nemsio_realfill
3117  endif
3118  if(iret.ne.0) iret=-6
3119  end subroutine nemsio_almeta2
3120 !------------------------------------------------------------------------------
3121  subroutine nemsio_almeta3(gfile,iret)
3122 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3123 ! abstract: allocate lon1d in gfile
3124 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3125  implicit none
3126  type(nemsio_gfile),intent(inout) :: gfile
3127  integer(nemsio_intkind),intent(out) :: iret
3128  integer :: dim1d
3129 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3130  dim1d=gfile%ntrac+1
3131  if(allocated(gfile%Cpi)) deallocate(gfile%Cpi)
3132  if(allocated(gfile%Ri)) deallocate(gfile%Ri)
3133  allocate(gfile%Cpi(dim1d),gfile%Ri(dim1d),stat=iret)
3134  if(iret.eq.0) then
3135  gfile%Cpi=nemsio_realfill
3136  gfile%Ri=nemsio_realfill
3137  endif
3138  if(iret.ne.0) iret=-6
3139  end subroutine nemsio_almeta3
3140 !------------------------------------------------------------------------------
3141  subroutine nemsio_almeta4(gfile,iret)
3142 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3143 ! abstract: allocate recnam, reclvevtyp, and reclev in gfile
3144 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3145  implicit none
3146  type(nemsio_gfile),intent(inout) :: gfile
3147  integer(nemsio_intkind),intent(out) :: iret
3148  integer :: dimrecname,dimreclevtyp,dimreclev
3149 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3150  dimrecname=gfile%nrec
3151  dimreclevtyp=gfile%nrec
3152  dimreclev=gfile%nrec
3153  if(allocated(gfile%recname)) deallocate(gfile%recname)
3154  if(allocated(gfile%reclevtyp)) deallocate(gfile%reclevtyp)
3155  if(allocated(gfile%reclev)) deallocate(gfile%reclev)
3156  allocate(gfile%recname(dimrecname), gfile%reclevtyp(dimreclevtyp), &
3157  gfile%reclev(dimreclev), stat=iret)
3158  if(iret.eq.0) then
3159  gfile%reclev=nemsio_intfill
3160  gfile%recname=' '
3161  gfile%reclevtyp=' '
3162  endif
3163  if(iret.ne.0) iret=-6
3164  end subroutine nemsio_almeta4
3165 !------------------------------------------------------------------------------
3166  subroutine nemsio_axmeta(gfile,iret)
3167 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3168 ! abstract: empty gfile variables and decallocate arrays in gfile
3169 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3170  implicit none
3171  type(nemsio_gfile),intent(inout) :: gfile
3172  integer(nemsio_intkind),intent(out) :: iret
3173 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3174  iret=-6
3175  gfile%gtype=' '
3176  gfile%gdatatype=' '
3177  gfile%modelname=' '
3178  gfile%version=nemsio_intfill
3179  gfile%nmeta=nemsio_intfill
3180  gfile%lmeta=nemsio_intfill
3181  gfile%nrec=nemsio_intfill
3182  gfile%idate(1:7)=nemsio_intfill
3183  gfile%nfday=nemsio_intfill
3184  gfile%nfhour=nemsio_intfill
3185  gfile%nfminute=nemsio_intfill
3186  gfile%nfsecondn=nemsio_intfill
3187  gfile%nfsecondd=nemsio_intfill
3188  gfile%dimx=nemsio_intfill
3189  gfile%dimy=nemsio_intfill
3190  gfile%dimz=nemsio_intfill
3191  gfile%nframe=nemsio_intfill
3192  gfile%nsoil=nemsio_intfill
3193  gfile%ntrac=nemsio_intfill
3194  gfile%jcap=nemsio_intfill
3195  gfile%ncldt=nemsio_intfill
3196  gfile%idvc=nemsio_intfill
3197  gfile%idsl=nemsio_intfill
3198  gfile%idvm=nemsio_intfill
3199  gfile%idrt=nemsio_intfill
3200  gfile%rlon_min=nemsio_realfill
3201  gfile%rlon_max=nemsio_realfill
3202  gfile%rlat_min=nemsio_realfill
3203  gfile%rlat_max=nemsio_realfill
3204  gfile%extrameta=nemsio_logicfill
3205  gfile%nmetavari=nemsio_intfill
3206  gfile%nmetavarr=nemsio_intfill
3207  gfile%nmetavarl=nemsio_intfill
3208  gfile%nmetavarc=nemsio_intfill
3209  gfile%nmetaaryi=nemsio_intfill
3210  gfile%nmetaaryr=nemsio_intfill
3211  gfile%nmetaaryl=nemsio_intfill
3212  gfile%nmetaaryc=nemsio_intfill
3213 
3214  if(allocated(gfile%recname)) deallocate(gfile%recname)
3215  if(allocated(gfile%reclevtyp)) deallocate(gfile%reclevtyp)
3216  if(allocated(gfile%reclev)) deallocate(gfile%reclev)
3217  if(allocated(gfile%vcoord)) deallocate(gfile%vcoord)
3218  if(allocated(gfile%lat)) deallocate(gfile%lat)
3219  if(allocated(gfile%lon)) deallocate(gfile%lon)
3220  if(allocated(gfile%dx)) deallocate(gfile%dx)
3221  if(allocated(gfile%dy)) deallocate(gfile%dy)
3222  if(allocated(gfile%Cpi)) deallocate(gfile%Cpi)
3223  if(allocated(gfile%Ri)) deallocate(gfile%Ri)
3224 !
3225  gfile%mbuf=0
3226  gfile%nnum=0
3227  gfile%nlen=0
3228  gfile%mnum=0
3229  if(allocated(gfile%cbuf)) deallocate(gfile%cbuf)
3230  if(allocated(gfile%headvariname)) deallocate(gfile%headvariname)
3231  if(allocated(gfile%headvarrname)) deallocate(gfile%headvarrname)
3232  if(allocated(gfile%headvarlname)) deallocate(gfile%headvarlname)
3233  if(allocated(gfile%headvarcname)) deallocate(gfile%headvarcname)
3234  if(allocated(gfile%headvarival)) deallocate(gfile%headvarival)
3235  if(allocated(gfile%headvarrval)) deallocate(gfile%headvarrval)
3236  if(allocated(gfile%headvarlval)) deallocate(gfile%headvarlval)
3237  if(allocated(gfile%headvarcval)) deallocate(gfile%headvarcval)
3238  if(allocated(gfile%headaryiname)) deallocate(gfile%headaryiname)
3239  if(allocated(gfile%headaryrname)) deallocate(gfile%headaryrname)
3240  if(allocated(gfile%headarycname)) deallocate(gfile%headarycname)
3241  if(allocated(gfile%headaryival)) deallocate(gfile%headaryival)
3242  if(allocated(gfile%headaryrval)) deallocate(gfile%headaryrval)
3243  if(allocated(gfile%headarycval)) deallocate(gfile%headarycval)
3244  iret=0
3245 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3246  end subroutine nemsio_axmeta
3247 !------------------------------------------------------------------------------
3248  subroutine nemsio_setfhead(gfile,iret)
3249 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3250 ! abstract: required file header (default)
3251 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3252  implicit none
3253  type(nemsio_gfile),intent(inout) :: gfile
3254  integer(nemsio_intkind),intent(out) :: iret
3255  integer(nemsio_intkind) i,j,k
3256 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3257  iret=-17
3258  gfile%headvarinum=29
3259  gfile%headvarrnum=4
3260  gfile%headvarlnum=1
3261  gfile%headvarcnum=3
3262  gfile%headaryinum=2
3263  gfile%headaryrnum=7
3264  gfile%headarycnum=2
3265 !
3266  allocate(gfile%headvariname(gfile%headvarinum),gfile%headvarival(gfile%headvarinum) )
3267  gfile%headvariname(1)='version'
3268  gfile%headvarival(1)=gfile%version
3269  gfile%headvariname(2)='nmeta'
3270  gfile%headvarival(2)=gfile%nmeta
3271  gfile%headvariname(3)='lmeta'
3272  gfile%headvarival(3)=gfile%lmeta
3273  gfile%headvariname(4)='nrec'
3274  gfile%headvarival(4)=gfile%nrec
3275  gfile%headvariname(5)='nfday'
3276  gfile%headvarival(5)=gfile%nfday
3277  gfile%headvariname(6)='nfhour'
3278  gfile%headvarival(6)=gfile%nfhour
3279  gfile%headvariname(7)='nfminute'
3280  gfile%headvarival(7)=gfile%nfminute
3281  gfile%headvariname(8)='nfsecondn'
3282  gfile%headvarival(8)=gfile%nfsecondn
3283  gfile%headvariname(9)='nfsecondd'
3284  gfile%headvarival(9)=gfile%nfsecondd
3285  gfile%headvariname(10)='dimx'
3286  gfile%headvarival(10)=gfile%dimx
3287  gfile%headvariname(11)='dimy'
3288  gfile%headvarival(11)=gfile%dimy
3289  gfile%headvariname(12)='dimz'
3290  gfile%headvarival(12)=gfile%dimz
3291  gfile%headvariname(13)='nframe'
3292  gfile%headvarival(13)=gfile%nframe
3293  gfile%headvariname(14)='nsoil'
3294  gfile%headvarival(14)=gfile%nsoil
3295  gfile%headvariname(15)='ntrac'
3296  gfile%headvarival(15)=gfile%ntrac
3297  gfile%headvariname(16)='jcap'
3298  gfile%headvarival(16)=gfile%jcap
3299  gfile%headvariname(17)='ncldt'
3300  gfile%headvarival(17)=gfile%ncldt
3301  gfile%headvariname(18)='idvc'
3302  gfile%headvarival(18)=gfile%idvc
3303  gfile%headvariname(19)='idsl'
3304  gfile%headvarival(19)=gfile%idsl
3305  gfile%headvariname(20)='idvm'
3306  gfile%headvarival(20)=gfile%idvm
3307  gfile%headvariname(21)='idrt'
3308  gfile%headvarival(21)=gfile%idrt
3309  gfile%headvariname(22)='nmetavari'
3310  gfile%headvarival(22)=gfile%nmetavari
3311  gfile%headvariname(23)='nmetavarr'
3312  gfile%headvarival(23)=gfile%nmetavarr
3313  gfile%headvariname(24)='nmetavarl'
3314  gfile%headvarival(24)=gfile%nmetavarl
3315  gfile%headvariname(25)='nmetavarc'
3316  gfile%headvarival(25)=gfile%nmetavarc
3317  gfile%headvariname(26)='nmetaaryi'
3318  gfile%headvarival(26)=gfile%nmetaaryi
3319  gfile%headvariname(27)='nmetaaryr'
3320  gfile%headvarival(27)=gfile%nmetaaryr
3321  gfile%headvariname(28)='nmetaaryl'
3322  gfile%headvarival(28)=gfile%nmetaaryl
3323  gfile%headvariname(29)='nmetaaryc'
3324  gfile%headvarival(29)=gfile%nmetaaryc
3325 !
3326  allocate(gfile%headvarrname(gfile%headvarrnum),gfile%headvarrval(gfile%headvarrnum) )
3327  gfile%headvarrname(1)='rlon_min'
3328  gfile%headvarrval(1)=gfile%rlon_min
3329  gfile%headvarrname(2)='rlon_max'
3330  gfile%headvarrval(2)=gfile%rlon_max
3331  gfile%headvarrname(3)='rlat_min'
3332  gfile%headvarrval(3)=gfile%rlat_min
3333  gfile%headvarrname(4)='rlat_min'
3334  gfile%headvarrval(4)=gfile%rlat_min
3335 !
3336  allocate(gfile%headvarcname(gfile%headvarcnum),gfile%headvarcval(gfile%headvarcnum) )
3337  gfile%headvarcname(1)='gtype'
3338  gfile%headvarcval(1)=gfile%gtype
3339  gfile%headvarcname(2)='modelname'
3340  gfile%headvarcval(2)=gfile%modelname
3341  gfile%headvarcname(3)='gdatatype'
3342  gfile%headvarcval(3)=gfile%gdatatype
3343 !head logic var
3344 ! write(0,*)'before setfhead, headvarl,nrec=',gfile%nrec
3345  allocate(gfile%headvarlname(gfile%headvarlnum),gfile%headvarlval(gfile%headvarlnum) )
3346  gfile%headvarlname(1)='extrameta'
3347  gfile%headvarlval(1)=gfile%extrameta
3348 !
3349 !--- gfile%head int ary
3350 ! write(0,*)'before setfhead, headaryi,nrec=',gfile%nrec,gfile%headaryinum
3351  allocate(gfile%headaryiname(gfile%headaryinum) )
3352  allocate(gfile%headaryival(max(size(gfile%reclev),7),gfile%headaryinum))
3353  gfile%headaryiname(1)='idate'
3354  gfile%headaryival(1:7,1)=gfile%idate(1:7)
3355  gfile%headaryiname(2)='reclev'
3356  if(allocated(gfile%reclev)) gfile%headaryival(:,2)=gfile%reclev(:)
3357 !
3358 !--- gfile%head real ary
3359 ! write(0,*)'before setfhead, headaryr,',gfile%headaryrnum ,gfile%fieldsize
3360  allocate(gfile%headaryrname(gfile%headaryrnum) )
3361  allocate(gfile%headaryrval(max(gfile%fieldsize,(gfile%dimz+1)*6),gfile%headaryrnum))
3362  gfile%headaryrname(1)='vcoord'
3363  if(allocated(gfile%vcoord)) then
3364  do j=1,2
3365  do i=1,3
3366  do k=1,gfile%dimz+1
3367  gfile%headaryrval(k+((j-1)*3+i-1)*(gfile%dimz+1),1)=gfile%vcoord(k,i,j)
3368  enddo
3369  enddo
3370  enddo
3371  endif
3372  gfile%headaryrname(2)='lat'
3373  if(allocated(gfile%lat)) gfile%headaryrval(:,2)=gfile%lat
3374  gfile%headaryrname(3)='lon'
3375  if(allocated(gfile%lon)) gfile%headaryrval(:,3)=gfile%lon
3376  gfile%headaryrname(4)='dx'
3377  if(allocated(gfile%dx)) gfile%headaryrval(:,4)=gfile%dx
3378  gfile%headaryrname(5)='dy'
3379  if(allocated(gfile%dy)) gfile%headaryrval(:,5)=gfile%dy
3380  gfile%headaryrname(6)='cpi'
3381  if(allocated(gfile%cpi)) gfile%headaryrval(1:size(gfile%cpi),6)=gfile%cpi(:)
3382  gfile%headaryrname(7)='ri'
3383  if(allocated(gfile%ri)) gfile%headaryrval(1:size(gfile%ri),7)=gfile%ri(:)
3384 !
3385 !--- gfile%head char var
3386 ! write(0,*)'before setfhead, headaryc,nrec=',gfile%nrec,gfile%headarycnum
3387  allocate(gfile%headarycname(gfile%headarycnum) )
3388  if(size(gfile%recname)>0) then
3389  allocate(gfile%headarycval(size(gfile%recname),gfile%headarycnum))
3390  gfile%headarycname(1)='recname'
3391  if(allocated(gfile%recname)) gfile%headarycval(:,1)=gfile%recname
3392  gfile%headarycname(2)='reclevtyp'
3393  if(allocated(gfile%reclevtyp)) gfile%headarycval(:,2)=gfile%reclevtyp
3394  endif
3395 !
3396 ! write(0,*)'end ef nemsio_setfhead'
3397  iret=0
3398  end subroutine nemsio_setfhead
3399 !------------------------------------------------------------------------------
3400  subroutine nemsio_getrechead(gfile,jrec,name,levtyp,lev,iret)
3401 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3402 ! abstract: given record number, return users record name, lev typ, and levs
3403 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3404  implicit none
3405  type(nemsio_gfile),intent(in) :: gfile
3406  integer(nemsio_intkind),intent(in) :: jrec
3407  character*(*),intent(out) :: name,levtyp
3408  integer(nemsio_intkind),intent(out) :: lev
3409  integer(nemsio_intkind),optional,intent(out) :: iret
3410  integer :: ios
3411 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3412  if( present(iret)) iret=-6
3413  if ( jrec.gt.0 .or. jrec.le.gfile%nrec) then
3414  name=gfile%recname(jrec)
3415  levtyp=gfile%reclevtyp(jrec)
3416  lev=gfile%reclev(jrec)
3417  if(present(iret)) iret=0
3418  return
3419  else
3420  if ( present(iret)) then
3421  return
3422  else
3423  call nemsio_stop
3424  endif
3425  endif
3426  end subroutine nemsio_getrechead
3427 !------------------------------------------------------------------------------
3428  subroutine nemsio_gfinit(gfile,iret,recname,reclevtyp,reclev)
3429 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3430 ! abstract: set gfile variables to operational model output
3431 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3432  implicit none
3433  type(nemsio_gfile),intent(inout) :: gfile
3434  integer(nemsio_intkind),intent(out) :: iret
3435  character(nemsio_charkind),optional,intent(in) :: recname(:)
3436  character(nemsio_charkind*2),optional,intent(in):: reclevtyp(:)
3437  integer(nemsio_intkind),optional,intent(in) :: reclev(:)
3438  integer :: i,j,rec,rec3dopt
3439  real(nemsio_dblekind),allocatable :: slat(:),wlat(:)
3440  real(nemsio_dblekind),allocatable :: dx(:)
3441  real(nemsio_dblekind) :: radi
3442  logical ::linit
3443 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3444 ! set operational format
3445 !
3446  iret=-8
3447  gfile%version=200809
3448  gfile%nfday=0
3449  gfile%nfhour=0
3450  gfile%nfminute=0
3451  gfile%nfsecondn=0
3452  gfile%nfsecondd=100
3453  gfile%extrameta=.false.
3454  gfile%nmetavari=0
3455  gfile%nmetavarr=0
3456  gfile%nmetavarl=0
3457  gfile%nmetavarc=0
3458  gfile%nmetaaryi=0
3459  gfile%nmetaaryr=0
3460  gfile%nmetaaryl=0
3461  gfile%nmetaaryc=0
3462 !
3463  iret=0
3464  end subroutine nemsio_gfinit
3465 !------------------------------------------------------------------------------
3466  subroutine nemsio_stop(message)
3467  implicit none
3468  character(*),optional,intent(in) :: message
3469  integer ::ios
3470 !---
3471  if ( present(message) ) print *,'message'
3472  call mpi_finalize(ios)
3473  stop
3474 !
3475  end subroutine nemsio_stop
3476 !------------------------------------------------------------------------------
3477 !
3478  subroutine nemsio_denseread4(gfile,ista,iend,jsta,jend,data,iret)
3479 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3480 ! abstract: free unit number array index corresponding to unit number
3481 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3482  implicit none
3483 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3484  type(nemsio_gfile),intent(inout) :: gfile
3485  integer,intent(in) :: ista,iend,jsta,jend
3486  real(nemsio_realkind),intent(out) :: data(:)
3487  integer,optional,intent(out) :: iret
3488 !--- local vars
3489  integer :: status(MPI_STATUS_SIZE)
3490  integer :: fieldmapsize,nfld,nfldloop,mfldrmd
3491  integer,allocatable :: fieldmap(:)
3492  integer ios,i,j,nfldsize,fieldmapsize1,k,nstt,nend
3493  integer(8) idispstt
3494  real(nemsio_dblekind),allocatable :: tmp(:)
3495 !---
3496  iret=-25
3497 !
3498  if(size(data)/=(iend-ista+1)*(jend-jsta+1)*gfile%nrec) then
3499  print *,'WRONG: data size ',size(data),' doesn"t match total subdomain data size', &
3500  (iend-ista+1)*(jend-jsta+1)*gfile%nrec
3501  return
3502  endif
3503 !--- set nfld
3504  if(gfile%gdatatype(1:4).eq.'bin4') then
3505  nfldsize=gfile%fieldsize+2
3506  elseif (gfile%gdatatype(1:4).eq.'bin8') then
3507  nfldsize=gfile%fieldsize+1
3508  endif
3509  nfld=min(gfile%nrec,nemsio_maxint/nfldsize)
3510  nfldloop=(gfile%nrec-1)/nfld+1
3511  mfldrmd=mod(gfile%nrec,nfld)
3512 ! print *,'in dense read,nfld=',nfld,'nfldloop=',nfldloop, &
3513 ! 'mfldrmd=',mfldrmd
3514 !--- set file map
3515  fieldmapsize=(iend-ista+1)*(jend-jsta+1)*nfld
3516  allocate(fieldmap(fieldmapsize) )
3517  call set_mpimap_read(gfile,ista,iend,jsta,jend,fieldmap,ios)
3518  if(ios.ne.0) return
3519 !---
3520  do k=1,nfldloop
3521 !
3522  if(k<nfldloop.or.mfldrmd==0) then
3523  nstt=(k-1)*fieldmapsize+1
3524  nend=k*fieldmapsize
3525  elseif(mfldrmd/=0) then
3526  nstt=(k-1)*fieldmapsize+1
3527  nend=gfile%nrec*(iend-ista+1)*(jend-jsta+1)
3528  deallocate(fieldmap)
3529  fieldmapsize=(iend-ista+1)*(jend-jsta+1)*mfldrmd
3530  allocate(fieldmap(fieldmapsize) )
3531 ! print *,'bf set_mpa_read,size=',fieldmapsize,'mfldrmd=',mfldrmd
3532  call set_mpimap_read(gfile,ista,iend,jsta,jend,fieldmap,ios)
3533  if(ios.ne.0) return
3534  endif
3535 
3536  if(gfile%gdatatype(1:4)=='bin4') then
3537  idispstt=int(k-1,8)*int(nfld,8)*int(gfile%fieldsize*4+8,8)
3538  call readmpi4(gfile,fieldmapsize,fieldmap,data(nstt:nend),ios,idispstt)
3539  else if (gfile%gdatatype(1:4)=='bin8') then
3540  allocate(tmp(size(data)))
3541  idispstt=int(k-1,8)*int(nfld,8)*int(gfile%fieldsize*8+8,8)
3542  call readmpi8(gfile,fieldmapsize,fieldmap,tmp(nstt:nend),ios,idispstt)
3543  data=tmp
3544  deallocate(tmp)
3545  endif
3546  if(ios.ne.0) return
3547 !
3548  enddo
3549  if(allocated(fieldmap))deallocate(fieldmap)
3550 !
3551  iret=0
3552 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3553  end subroutine nemsio_denseread4
3554 !------------------------------------------------------------------------------
3555  subroutine nemsio_denseread8(gfile,ista,iend,jsta,jend,data,iret)
3556 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3557 ! abstract: read all the fields out in real 8 MPI
3558 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3559  implicit none
3560 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3561  type(nemsio_gfile),intent(inout) :: gfile
3562  integer,intent(in) :: ista,iend,jsta,jend
3563  real(nemsio_dblekind),intent(out) :: data(:)
3564  integer,optional,intent(out) :: iret
3565 !--- local vars
3566  integer :: fieldmapsize
3567  integer,allocatable :: fieldmap(:)
3568  integer ios,i,j,nfldsize,nfld,nfldloop,mfldrmd,k,nstt,nend
3569  integer(8) idispstt
3570  real(nemsio_realkind),allocatable :: tmp(:)
3571 !---
3572  iret=-25
3573 !
3574  if(size(data)/=(iend-ista+1)*(jend-jsta+1)*gfile%nrec) then
3575  print *,'WRONG: data size ',size(data),' doesn"t match total subdomain data size', &
3576  (iend-ista+1)*(jend-jsta+1)*gfile%nrec
3577  return
3578  endif
3579 !--- set nfld
3580  if(gfile%gdatatype(1:4).eq.'bin4') then
3581  nfldsize=gfile%fieldsize+2
3582  elseif (gfile%gdatatype(1:4).eq.'bin8') then
3583  nfldsize=gfile%fieldsize+1
3584  endif
3585  nfld=min(gfile%nrec,nemsio_maxint/nfldsize)
3586  nfldloop=(gfile%nrec-1)/nfld+1
3587  mfldrmd=mod(gfile%nrec,nfld)
3588 ! write(0,*)'in dense read,nfld=',nfld,'nfldloop=',nfldloop, &
3589 ! 'mfldrmd=',mfldrmd
3590 !--- set file map
3591  fieldmapsize=(iend-ista+1)*(jend-jsta+1)*nfld
3592  allocate(fieldmap(fieldmapsize) )
3593  call set_mpimap_read(gfile,ista,iend,jsta,jend,fieldmap,ios)
3594  if(ios.ne.0) return
3595 !---
3596  do k=1,nfldloop
3597 !
3598  if(k<nfldloop.or.mfldrmd==0) then
3599  nstt=(k-1)*fieldmapsize+1
3600  nend=k*fieldmapsize
3601  elseif(mfldrmd/=0) then
3602  nstt=(k-1)*fieldmapsize+1
3603  nend=gfile%nrec*(iend-ista+1)*(jend-jsta+1)
3604  deallocate(fieldmap)
3605  fieldmapsize=(iend-ista+1)*(jend-jsta+1)*mfldrmd
3606  allocate(fieldmap(fieldmapsize) )
3607  call set_mpimap_read(gfile,ista,iend,jsta,jend,fieldmap,ios)
3608  if(ios.ne.0) return
3609  endif
3610 !
3611 !---
3612  if(gfile%gdatatype(1:4)=='bin4') then
3613  allocate(tmp(size(data)))
3614  idispstt=int(k-1,8)*int(nfld,8)*int(gfile%fieldsize*4+8,8)
3615  call readmpi4(gfile,fieldmapsize,fieldmap,tmp,ios,idispstt)
3616  data=tmp
3617  deallocate(tmp)
3618  elseif(gfile%gdatatype(1:4)=='bin8') then
3619  idispstt=int(k-1,8)*int(nfld,8)*int(gfile%fieldsize*8+8,8)
3620  call readmpi8(gfile,fieldmapsize,fieldmap,data,ios,idispstt)
3621  endif
3622  if(ios.ne.0) return
3623  enddo
3624  if(allocated(fieldmap))deallocate(fieldmap)
3625 !
3626  iret=0
3627 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3628  end subroutine nemsio_denseread8
3629 !------------------------------------------------------------------------------
3630  subroutine readmpi4(gfile,fieldmapsize,fieldmap,data,iret,idispstt)
3631 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3632 ! abstract: read real 4 data out using MPI
3633 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3634  implicit none
3635 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3636  type(nemsio_gfile),intent(inout) :: gfile
3637  integer,intent(in) :: fieldmapsize
3638  integer,intent(in) :: fieldmap(fieldmapsize)
3639  real(nemsio_realkind),intent(out) :: data(fieldmapsize)
3640  integer,optional,intent(out) :: iret
3641  integer(8),optional,intent(in) :: idispstt
3642 !local vars
3643  integer(MPI_OFFSET_KIND) :: idisp
3644  integer :: filetype,ios
3645  integer :: status(MPI_STATUS_SIZE)
3646 !
3647 !--- set file type
3648  call mpi_type_create_indexed_block(fieldmapsize,1,fieldmap, &
3649  mpi_real,filetype,ios)
3650 
3651  call mpi_type_commit(filetype,iret)
3652  if ( ios.ne.0 ) then
3653  if ( present(iret)) then
3654  iret=ios
3655  return
3656  else
3657  call nemsio_stop('stop at MPI set field map!')
3658  endif
3659  endif
3660 !
3661 !--- file set view, and read
3662  if(present(idispstt)) then
3663  idisp=gfile%tlmeta+4+idispstt
3664  else
3665  idisp=gfile%tlmeta+4
3666  endif
3667  call mpi_file_set_view(gfile%fh,idisp,mpi_real4,filetype,'native', &
3668  mpi_info_null,ios)
3669  call mpi_file_read_all(gfile%fh,data,fieldmapsize,mpi_real4, &
3670  status,ios)
3671  if ( ios.ne.0 ) then
3672  if ( present(iret)) then
3673  iret=ios
3674  return
3675  else
3676  call nemsio_stop('stop at MPI read file all for bin4!')
3677  endif
3678  endif
3679  if(gfile%do_byteswap) call byteswap(data,nemsio_realkind,size(data))
3680 !
3681  iret=0
3682 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3683  end subroutine readmpi4
3684 !------------------------------------------------------------------------------
3685  subroutine readmpi8(gfile,fieldmapsize,fieldmap,data,iret,idispstt)
3686 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3687 ! abstract: free unit number array index corresponding to unit number
3688 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3689  implicit none
3690 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3691  type(nemsio_gfile),intent(inout) :: gfile
3692  integer,intent(in) :: fieldmapsize
3693  integer,intent(in) :: fieldmap(fieldmapsize)
3694  real(nemsio_dblekind),intent(out) :: data(fieldmapsize)
3695  integer,optional,intent(out) :: iret
3696  integer(8),optional,intent(in) :: idispstt
3697 !local vars
3698  integer(MPI_OFFSET_KIND) :: idisp
3699  integer :: filetype,ios
3700  integer :: status(MPI_STATUS_SIZE)
3701 !---
3702  iret=-25
3703 !
3704 !--- set file type
3705  call mpi_type_create_indexed_block(fieldmapsize,1,fieldmap, &
3706  mpi_real8,filetype,ios)
3707  call mpi_type_commit(filetype,iret)
3708  if ( ios.ne.0 ) then
3709  if ( present(iret)) then
3710  iret=ios
3711  return
3712  else
3713  call nemsio_stop('stop at MPI set field map!')
3714  endif
3715  endif
3716 !
3717 !--- file set view, and read
3718  if(present(idispstt)) then
3719  idisp=gfile%tlmeta+4+idispstt
3720  else
3721  idisp=gfile%tlmeta+4
3722  endif
3723  call mpi_file_set_view(gfile%fh,idisp,mpi_real8,filetype,'native', &
3724  mpi_info_null,ios)
3725  call mpi_file_read_all(gfile%fh,data,fieldmapsize,mpi_real8, &
3726  status,ios)
3727  if ( ios.ne.0 ) then
3728  if ( present(iret)) then
3729  iret=ios
3730  return
3731  else
3732  call nemsio_stop('stop at MPI read file all for bin8!')
3733  endif
3734  endif
3735 !
3736  iret=0
3737 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3738  end subroutine readmpi8
3739 !------------------------------------------------------------------------------
3740  subroutine set_mpimap_read(gfile,ista,iend,jsta,jend,fieldmap,iret,jrec)
3741 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3742 ! abstract: free unit number array index corresponding to unit number
3743 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3744  implicit none
3745 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3746  type(nemsio_gfile),intent(in) :: gfile
3747  integer,intent(in) :: ista,iend,jsta,jend
3748  integer,intent(out) :: fieldmap(:)
3749  integer,intent(out) :: iret
3750  integer,optional,intent(in) :: jrec
3751 !-- local vars
3752  integer i,j,k,m,jm,km,nfieldsize,nfld,krec,kstart
3753 !---
3754  iret=-20
3755 !---
3756  if(gfile%gdatatype(1:4).eq.'bin4') then
3757  nfieldsize=gfile%fieldsize+2
3758  elseif (gfile%gdatatype(1:4).eq.'bin8') then
3759  nfieldsize=gfile%fieldsize+1
3760  endif
3761 !---
3762  if(present(jrec)) then
3763  krec=jrec
3764  nfld=1
3765  else
3766  krec=1
3767  nfld=size(fieldmap)/((iend-ista+1)*(jend-jsta+1))
3768  endif
3769 !--- set file map
3770  kstart=(krec-1)*nfieldsize
3771 ! write(0,*)'in set_mpimap, kstart=',kstart,' tlmeta=',gfile%tlmeta, &
3772 ! ' nfieldsize=',nfieldsize,'krec=',krec,'nfld=',nfld,'fldsize=',gfile%fieldsize, &
3773 ! 'dimx=',gfile%dimx,'dimy=',gfile%dimy,'nfrmae=',gfile%nframe
3774 !
3775  if (gfile%nframe.eq.0) then
3776  m=0
3777  do k=1,nfld
3778  km=(k-1)*nfieldsize+kstart-1
3779  do j=jsta,jend
3780  jm=(j-1)*gfile%dimx
3781  do i=ista,iend
3782  m=m+1
3783  fieldmap(m)=i+jm+km
3784  enddo
3785  enddo
3786  enddo
3787  else if(gfile%nframe.gt.0) then
3788  m=0
3789  do k=1,nfld
3790  km=(k-1)*nfieldsize+kstart-1
3791  do j=jsta,jend
3792  jm=(j-1)*(gfile%dimx+2*gfile%nframe)
3793  do i=ista,iend
3794  m=m+1
3795  fieldmap(m)=i+jm+km
3796  enddo
3797  enddo
3798  enddo
3799  endif
3800 !
3801  iret=0
3802 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3803  end subroutine set_mpimap_read
3804 !------------------------------------------------------------------------------
3805  subroutine set_mpimap_wrt(gfile,ista,iend,jsta,jend,fieldmap,iret,jrec)
3806 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3807 ! abstract: free unit number array index corresponding to unit number
3808 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3809  implicit none
3810 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3811  type(nemsio_gfile),intent(in) :: gfile
3812  integer,intent(in) :: ista,iend,jsta,jend
3813  integer,intent(out) :: fieldmap(:)
3814  integer,intent(out) :: iret
3815  integer,optional,intent(in) :: jrec
3816 !-- local vars
3817  integer i,j,k,m,jm,km,nfieldsize,nfld,krec,kstart,inum
3818 !---
3819  iret=-20
3820 !---
3821  if(present(jrec)) then
3822  krec=jrec
3823  nfld=1
3824  else
3825  krec=1
3826  if(gfile%mype==gfile%lead_task) then
3827  nfld=size(fieldmap)/((iend-ista+1)*(jend-jsta+1)+2)
3828  else
3829  nfld=size(fieldmap)/((iend-ista+1)*(jend-jsta+1))
3830  endif
3831  endif
3832 !--- set file map
3833  nfieldsize=gfile%fieldsize+2
3834  kstart=(krec-1)*nfieldsize
3835 !
3836 
3837  if (gfile%nframe.eq.0) then
3838  inum=gfile%dimx
3839  elseif(gfile%nframe.gt.0) then
3840  inum=gfile%dimx+2*gfile%nframe
3841  endif
3842 !
3843  m=0
3844  do k=1,nfld
3845  km=(k-1)*nfieldsize+kstart
3846  if(gfile%mype.eq.gfile%lead_task) then
3847  m=m+1
3848  fieldmap(m)=km
3849  endif
3850  do j=jsta,jend
3851  jm=(j-1)*inum
3852  do i=ista,iend
3853  m=m+1
3854  fieldmap(m)=i+jm+km
3855  enddo
3856  enddo
3857  if(gfile%mype.eq.gfile%lead_task) then
3858  m=m+1
3859  fieldmap(m)=km+nfieldsize-1
3860  endif
3861  enddo
3862 !
3863  iret=0
3864 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3865  end subroutine set_mpimap_wrt
3866 !------------------------------------------------------------------------------
3867  subroutine nemsio_densewrite4(gfile,ista,iend,jsta,jend,data,jrecs,jrece,iret)
3868 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3869 ! abstract: free unit number array index corresponding to unit number
3870 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3871  implicit none
3872 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3873  type(nemsio_gfile),intent(inout) :: gfile
3874  integer,intent(in) :: ista,iend,jsta,jend
3875  real(nemsio_realkind),intent(in) :: data(:)
3876  integer,optional,intent(in) :: jrecs,jrece
3877  integer,optional,intent(out) :: iret
3878 !
3879  real(nemsio_dblekind),allocatable :: data8(:)
3880 !
3881  if(gfile%gdatatype(1:4)=='bin4') then
3882  call mpi_densewrite4(gfile,ista,iend,jsta,jend,data,jrecs,jrece,iret)
3883  else if (gfile%gdatatype(1:4)=='bin8') then
3884  allocate(data8(size(data)))
3885  data8=data
3886  call mpi_densewrite8(gfile,ista,iend,jsta,jend,data8,jrecs,jrece,iret)
3887  deallocate(data8)
3888  endif
3889 !
3890  end subroutine nemsio_densewrite4
3891 !------------------------------------------------------------------------------
3892  subroutine nemsio_densewrite8(gfile,ista,iend,jsta,jend,data,jrecs,jrece,iret)
3893 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3894 ! abstract: free unit number array index corresponding to unit number
3895 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3896  implicit none
3897 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3898  type(nemsio_gfile),intent(inout) :: gfile
3899  integer,intent(in) :: ista,iend,jsta,jend
3900  real(nemsio_dblekind),intent(in) :: data(:)
3901  integer,optional,intent(in) :: jrecs,jrece
3902  integer,optional,intent(out) :: iret
3903 !
3904  real(nemsio_realkind),allocatable :: data4(:)
3905 !
3906  if(gfile%gdatatype(1:4)=='bin4') then
3907  allocate(data4(size(data)))
3908  data4=data
3909  call mpi_densewrite4(gfile,ista,iend,jsta,jend,data4,jrecs,jrece,iret)
3910  deallocate(data4)
3911  else if (gfile%gdatatype(1:4)=='bin8') then
3912  call mpi_densewrite8(gfile,ista,iend,jsta,jend,data,jrecs,jrece,iret)
3913  endif
3914 !
3915  end subroutine nemsio_densewrite8
3916 !
3917 !------------------------------------------------------------------------------
3918  subroutine mpi_densewrite4(gfile,ista,iend,jsta,jend,data,jrecs,jrece,iret)
3919 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3920 ! abstract: free unit number array index corresponding to unit number
3921 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
3922  implicit none
3923 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3924  type(nemsio_gfile),intent(inout) :: gfile
3925  integer,intent(in) :: ista,iend,jsta,jend
3926  real(nemsio_realkind),intent(in) :: data(:)
3927  integer,optional,intent(in) :: jrecs,jrece
3928  integer,optional,intent(out) :: iret
3929 !--- local vars
3930  integer :: i,ios,nfldsize,nfld,nfldloop,mfldrmd,k
3931  integer :: fieldmapsize,fldmapsize1,fldmapsize
3932  integer,allocatable :: fieldmap(:)
3933  real(nemsio_realkind),allocatable :: datatmp(:)
3934  integer irecs,irece,nfldlp,mrec,mrecs,filetype
3935  integer(8) idispstt,fielddatasize
3936 !---
3937  iret=-25
3938 !
3939 !--- set nfld
3940  if(present(jrecs).and.present(jrece)) then
3941  mrec=jrece-jrecs+1
3942  mrecs=jrecs
3943  else
3944  mrec=gfile%nrec
3945  mrecs=1
3946  endif
3947  nfldsize=gfile%fieldsize+2
3948  nfld=min(mrec,nemsio_maxint/(nfldsize*2))
3949  nfldloop=(mrec-1)/nfld+1
3950  mfldrmd=mod(mrec,nfld)
3951 !
3952 !--- set file map
3953  if(gfile%mype==gfile%lead_task) then
3954  fieldmapsize=((iend-ista+1)*(jend-jsta+1)+2)*nfld
3955  fldmapsize=(iend-ista+1)*(jend-jsta+1)+2
3956  fldmapsize1=(iend-ista+1)*(jend-jsta+1)
3957  else
3958  fldmapsize=(iend-ista+1)*(jend-jsta+1)
3959  fieldmapsize=(iend-ista+1)*(jend-jsta+1)*nfld
3960  endif
3961  allocate(datatmp(fieldmapsize))
3962  allocate(fieldmap(fieldmapsize) )
3963  call set_mpimap_wrt(gfile,ista,iend,jsta,jend,fieldmap,ios)
3964  if(ios.ne.0) return
3965 !
3966 !--- set file type
3967  call mpi_type_create_indexed_block(fieldmapsize,1,fieldmap, &
3968  mpi_real,filetype,ios)
3969  call mpi_type_commit(filetype,ios)
3970  if ( ios.ne.0 ) then
3971  if ( present(iret)) then
3972  iret=ios
3973  return
3974  else
3975  call nemsio_stop('stop: at write set type indexed block')
3976  endif
3977  endif
3978 !
3979 !---
3980  do k=1,nfldloop
3981 !
3982  irecs=(k-1)*nfld
3983  if(k<nfldloop.or.mfldrmd==0) then
3984  irece=k*nfld
3985  nfldlp=nfld
3986  elseif(mfldrmd/=0) then
3987  deallocate(fieldmap,datatmp)
3988  fieldmapsize=fldmapsize*mfldrmd
3989  allocate(fieldmap(fieldmapsize) )
3990  allocate(datatmp(fieldmapsize) )
3991  call set_mpimap_wrt(gfile,ista,iend,jsta,jend,fieldmap,ios)
3992  if(ios.ne.0) return
3993 !
3994 !--- set file type
3995  call mpi_type_create_indexed_block(fieldmapsize,1,fieldmap, &
3996  mpi_real,filetype,ios)
3997  call mpi_type_commit(filetype,ios)
3998  if ( ios.ne.0 ) then
3999  if ( present(iret)) then
4000  iret=ios
4001  return
4002  else
4003  call nemsio_stop('stop: at write set type indexed block')
4004  endif
4005  endif
4006 
4007  irece=mrec
4008  nfldlp=mfldrmd
4009  endif
4010 !
4011 !--- prepare data
4012  do i=1,nfldlp
4013  if(gfile%mype.eq.gfile%lead_task) then
4014  datatmp((i-1)*fldmapsize+1)=gfile%fieldsize_real4
4015  datatmp(i*fldmapsize)=datatmp(1)
4016  datatmp((i-1)*fldmapsize+2:i*fldmapsize-1)=data((irecs+i-1)*fldmapsize1+1:(irecs+i)*fldmapsize1)
4017  else
4018  datatmp((i-1)*fldmapsize+1:i*fldmapsize)=data((irecs+i-1)*fldmapsize+1:(irecs+i)*fldmapsize)
4019  endif
4020  enddo
4021 !
4022  idispstt=(int(k-1,8)*int(nfld,8)+int(mrecs-1,8))*int(nfldsize*4,8)
4023 
4024  call writempi4(gfile,fieldmapsize,filetype,datatmp,iret=iret, &
4025  idispstt=idispstt)
4026  if (iret.ne.0) return
4027 !
4028  enddo
4029  deallocate(fieldmap,datatmp)
4030 !
4031  iret=0
4032 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4033  end subroutine mpi_densewrite4
4034 !------------------------------------------------------------------------------
4035  subroutine mpi_densewrite8(gfile,ista,iend,jsta,jend,data,jrecs,jrece,iret)
4036 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
4037 ! abstract: free unit number array index corresponding to unit number
4038 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
4039  implicit none
4040 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4041  type(nemsio_gfile),intent(inout) :: gfile
4042  integer,intent(in) :: ista,iend,jsta,jend
4043  real(nemsio_dblekind),intent(in) :: data(:)
4044  integer,optional,intent(in) :: jrecs,jrece
4045  integer,optional,intent(out) :: iret
4046 !--- local vars
4047  integer :: i,ios,nfldsize,nfld,nfldloop,mfldrmd,k
4048  integer :: fieldmapsize,fldmapsize,fldmapsize1,fielddatasize
4049  integer,allocatable :: fieldmap(:)
4050  real(nemsio_dblekind),allocatable :: datatmp(:)
4051  integer irecs,irece,nfldlp,mrec,mrecs
4052  integer(8) idispstt
4053  integer filetype
4054 !---
4055  iret=-25
4056 !
4057 !--- set nfld
4058  if(present(jrecs).and.present(jrece)) then
4059  mrec=jrece-jrecs+1
4060  mrecs=jrecs
4061  else
4062  mrec=gfile%nrec
4063  mrecs=1
4064  endif
4065  nfldsize=gfile%fieldsize+2
4066  nfld=min(mrec,nemsio_maxint/(nfldsize*2))
4067  nfldloop=(mrec-1)/nfld+1
4068  mfldrmd=mod(mrec,nfld)
4069 ! write(0,*)'in dense read,nfld=',nfld,'nfldloop=',nfldloop, &
4070 ! 'mfldrmd=',mfldrmd
4071 !
4072 !--- set file map
4073  if(gfile%mype==gfile%lead_task) then
4074  fieldmapsize=((iend-ista+1)*(jend-jsta+1)+2)*nfld
4075  fldmapsize=(iend-ista+1)*(jend-jsta+1)+2
4076  fldmapsize1=(iend-ista+1)*(jend-jsta+1)
4077  else
4078  fldmapsize=(iend-ista+1)*(jend-jsta+1)
4079  fieldmapsize=(iend-ista+1)*(jend-jsta+1)*nfld
4080  endif
4081  allocate(datatmp(fieldmapsize))
4082  allocate(fieldmap(fieldmapsize) )
4083  call set_mpimap_wrt(gfile,ista,iend,jsta,jend,fieldmap,ios)
4084  if(ios.ne.0) return
4085 !
4086 !--- set file type
4087  call mpi_type_create_indexed_block(fieldmapsize,1,fieldmap, &
4088  mpi_real8,filetype,ios)
4089  call mpi_type_commit(filetype,ios)
4090  if ( ios.ne.0 ) then
4091  if ( present(iret)) then
4092  iret=ios
4093  return
4094  else
4095  call nemsio_stop('stop: at write set type indexed block')
4096  endif
4097  endif
4098 !
4099 !---
4100  do k=1,nfldloop
4101 !
4102  irecs=(k-1)*nfld+1
4103  if(k<nfldloop.or.mfldrmd==0) then
4104  nfldlp=nfld
4105  irece=k*nfld
4106  elseif(mfldrmd/=0) then
4107  deallocate(fieldmap,datatmp)
4108  fieldmapsize=fldmapsize*mfldrmd
4109  allocate(fieldmap(fieldmapsize) )
4110  allocate(datatmp(fieldmapsize) )
4111  call set_mpimap_wrt(gfile,ista,iend,jsta,jend,fieldmap,ios)
4112  if(ios.ne.0) return
4113 !
4114 !--- set file type
4115  call mpi_type_create_indexed_block(fieldmapsize,1,fieldmap, &
4116  mpi_real8,filetype,ios)
4117  call mpi_type_commit(filetype,ios)
4118  if ( ios.ne.0 ) then
4119  if ( present(iret)) then
4120  iret=ios
4121  return
4122  else
4123  call nemsio_stop('stop: at write set type indexed block')
4124  endif
4125  endif
4126 
4127  nfldlp=mfldrmd
4128  irece=mrec
4129  endif
4130 !
4131 !--- prepare data
4132  do i=1,nfldlp
4133  if(gfile%mype.eq.gfile%lead_task) then
4134  datatmp((i-1)*fldmapsize+1)=gfile%fieldsize_real8
4135  datatmp(i*fldmapsize+2)=datatmp(1)
4136  datatmp((i-1)*fldmapsize+2:i*fldmapsize+1)=data((irecs+i-1)*fldmapsize1+1:(irecs+i)*fldmapsize1)
4137  else
4138  datatmp((i-1)*fldmapsize+1:i*fldmapsize)=data((irecs+i-1)*fldmapsize+1:(irecs+i)*fldmapsize)
4139  endif
4140  enddo
4141 
4142  idispstt=(int(k-1,8)*int(nfld,8)+int(mrecs-1,8))*int(gfile%fieldsize*8+8,8)
4143 !
4144  call writempi8(gfile,fieldmapsize,filetype,datatmp,iret=iret,idispstt=idispstt)
4145  if(iret/=0) return
4146  enddo
4147  deallocate(fieldmap,datatmp)
4148 !
4149  iret=0
4150 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4151  end subroutine mpi_densewrite8
4152 !------------------------------------------------------------------------------
4153  subroutine writempi4(gfile,fieldmapsize,filetype,data,iret,idispstt)
4154 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
4155 ! abstract: write out real 4 data using MPI
4156 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
4157  implicit none
4158 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4159  type(nemsio_gfile),intent(inout) :: gfile
4160  integer,intent(in) :: fieldmapsize
4161  integer,intent(in) :: filetype
4162  real(nemsio_realkind),intent(in) :: data(:)
4163  integer,optional,intent(out) :: iret
4164  integer(8),optional,intent(in) :: idispstt
4165 !--- local vars
4166  integer(MPI_OFFSET_KIND) :: idisp
4167  integer :: status(MPI_STATUS_SIZE)
4168  integer ios
4169 !
4170 !--- file set view, and read
4171 !
4172  if(present(idispstt)) then
4173  idisp=gfile%tlmeta+idispstt
4174  else
4175  idisp=gfile%tlmeta
4176  endif
4177  call mpi_file_set_view(gfile%fh,idisp,mpi_real4,filetype,'native', &
4178  mpi_info_null,ios)
4179  if(gfile%do_byteswap) call byteswap(data,nemsio_realkind,size(data))
4180  call mpi_file_write_all(gfile%fh,data,fieldmapsize,mpi_real4, &
4181  status,ios)
4182  if(gfile%do_byteswap) call byteswap(data,nemsio_realkind,size(data))
4183  if ( ios.ne.0 ) then
4184  if ( present(iret)) then
4185  iret=ios
4186  return
4187  else
4188  call nemsio_stop('stop: at MPI write all for bin4')
4189  endif
4190  endif
4191 !
4192  iret=0
4193 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4194  end subroutine writempi4
4195 !------------------------------------------------------------------------------
4196  subroutine writempi8(gfile,fieldmapsize,filetype,data,iret,idispstt)
4197 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
4198 ! abstract: write out real 8 data using MPI
4199 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - -
4200  implicit none
4201 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4202  type(nemsio_gfile),intent(inout) :: gfile
4203  integer,intent(in) :: fieldmapsize
4204  integer,intent(in) :: filetype
4205  real(nemsio_dblekind),intent(in) :: data(:)
4206  integer,optional,intent(out) :: iret
4207  integer(8),optional,intent(in) :: idispstt
4208 !--- local vars
4209  integer(MPI_OFFSET_KIND) :: idisp
4210  integer :: status(MPI_STATUS_SIZE)
4211  integer ios
4212 !---
4213  iret=-25
4214 !
4215 !--- file set view, and read
4216 !
4217  if(present(idispstt)) then
4218  idisp=gfile%tlmeta+idispstt
4219  else
4220  idisp=gfile%tlmeta
4221  endif
4222  call mpi_file_set_view(gfile%fh,idisp,mpi_real8,filetype,'native', &
4223  mpi_info_null,ios)
4224  if(gfile%do_byteswap) call byteswap(data,nemsio_dblekind,size(data))
4225  call mpi_file_write_all(gfile%fh,data,fieldmapsize,mpi_real8, &
4226  status,ios)
4227  if ( ios.ne.0 ) then
4228  if ( present(iret)) then
4229  iret=ios
4230  return
4231  else
4232  call nemsio_stop('stop: at MPI write all for bin8')
4233  endif
4234  endif
4235  if(gfile%do_byteswap) call byteswap(data,nemsio_dblekind,size(data))
4236 !
4237  iret=0
4238 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
4239  end subroutine writempi8
4240 !
4241 !------------------------------------------------------------------------------
4242 !
4243  elemental function equal_str_nocase(str1,str2)
4244 !
4245 !-----------------------------------------------------------------------
4246 !
4247 ! convert a word to lower case
4248 !
4249  logical :: equal_str_nocase
4250  Character (len=*) , intent(in) :: str1
4251  Character (len=*) , intent(in) :: str2
4252  integer :: i,ic1,ic2,nlen
4253  nlen = len(str2)
4254 !
4255  if(len(str1)/=nlen) then
4256  equal_str_nocase=.false.
4257  return
4258  endif
4259  equal_str_nocase=.false.
4260  do i=1,nlen
4261  ic1 = ichar(str1(i:i))
4262  if (ic1 >= 65 .and. ic1 < 91) ic1 = ic1+32
4263  ic2 = ichar(str2(i:i))
4264  if (ic2 >= 65 .and. ic2 < 91) ic2 = ic2+32
4265  if(ic1/=ic2) then
4266  equal_str_nocase=.false.
4267  return
4268  endif
4269  end do
4270  equal_str_nocase=.true.
4271 !
4272 !-----------------------------------------------------------------------
4273 !
4274  end function equal_str_nocase
4275 !
4276 !-----------------------------------------------------------------------
4277 !
4278  subroutine chk_endianc(endian)
4279 !
4280  implicit none
4281 !
4282  character(16),intent(out) :: endian
4283 ! ------------------------------------------------------------------
4284  INTEGER,PARAMETER :: ASCII_0 = 48,ascii_1 = 49,ascii_2 = 50, &
4285  ascii_3 = 51
4286  INTEGER(4) :: I
4287  common// i
4288 ! ------------------------------------------------------------------
4289 !***** code start
4290 ! ------------------------------------------------------------------
4291  i = ascii_0 + ascii_1*256 + ascii_2*(256**2) + ascii_3*(256**3)
4292  call sub(endian)
4293 !
4294 ! ------------------------------------------------------------------
4295 !
4296  end subroutine chk_endianc
4297 !
4298 !-----------------------------------------------------------------------
4299 !
4300  subroutine sub(endian)
4301 !
4302  implicit none
4303 !
4304  character(16),intent(out) :: endian
4305 ! character,intent(inout) :: i*4
4306  character :: i*4
4307  common// i
4308 ! ------------------------------------------------------------------
4309  if(i .eq. '0123') then
4310 ! WRITE(*,*) ' Machine is Little-Endian '
4311  endian='little_endian'
4312  return
4313  elseif (i .eq. '3210') then
4314 ! WRITE(*,*) ' Machine is Big-Endian '
4315  endian='big_endian'
4316  return
4317  else
4318 ! WRITE(*,*) ' Mixed endianity machine ... '
4319  endian='mixed_endian'
4320  return
4321  endif
4322 !
4323 ! ------------------------------------------------------------------
4324 !
4325  end subroutine sub
4326 !
4327 !------------------------------------------------------------------------------
4328  end module nemsio_module_mpi
nemsio_module_mpi::nemsio_gfile
Definition: nemsio_module_mpi.f90:144