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