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