NCEPLIBS-nemsio  2.5.3
•All Data Structures Files
nemsio_get.f90
Go to the documentation of this file.
1 
5  program main
6 !
7  use nemsio_module
8  implicit none
9 !
10  type(nemsio_gfile) :: gfile
11 !
12  character(255) cin,filenm
13  character(16) varname
14  character(16) varlevtyp
15  character(3) cvarlev
16  integer varlev
17  real,allocatable :: data(:)
18 !---------------------------------------------------------------------------
19 !--- nemsio meta data
20  integer nrec,im,jm,nframe,nmetaaryi,nmetaaryr,nmetaaryl,nmetaaryc, &
21  nmetaaryr8,i,j,fieldsize,iret,idate(7),levs,ntrac, tlmeta
22  integer ivar
23  real(4) rvar
24  real(8) r8var
25  logical lvar
26  character(10) odate
27  character(16) cvar, file_endian
28  character(35) mystr,sweep_blanks
29  character(4) gdatatype
30  character(16),allocatable:: recname(:)
31  character(16),allocatable :: reclevtyp(:)
32  integer,allocatable:: reclev(:)
33  real(4),allocatable ::vcoord(:,:,:),lat(:),lon(:),cpi(:),ri(:),dx(:),dy(:)
34 !---------------------------------------------------------------------------
35 !
36  character(16),allocatable :: aryiname(:),aryrname(:),arylname(:),arycname(:),&
37  aryr8name(:)
38  integer,allocatable :: aryilen(:),aryrlen(:),aryllen(:),aryclen(:),aryr8len(:)
39  integer,allocatable :: iary(:)
40  real(4),allocatable :: rary(:)
41  real(8),allocatable :: r8ary(:)
42  logical,allocatable :: lary(:)
43  character(16),allocatable :: cary(:)
44 !
45 !-------------set up nemsio write--------------------------
46  call nemsio_init(iret=iret)
47 !
48 !---------------------------------------------------------------------------
49 !******Example 2: read full history file
50 !---------------------------------------------------------------------------
51 !--- open gfile for reading
52  call getarg(1,cin)
53  call nemsio_open(gfile,trim(cin),'READ',iret=iret)
54  if (iret .ne.0 ) then
55  print *,'ERROR: can not open file ',trim(cin)
56  stop
57  endif
58 !
59  call nemsio_getfilehead(gfile,iret=iret,gdatatype=gdatatype,dimx=im,dimy=jm, &
60  nframe=nframe,dimz=levs,nrec=nrec,ntrac=ntrac,tlmeta=tlmeta, &
61  file_endian=file_endian,nmetaaryi=nmetaaryi,nmetaaryr=nmetaaryr, &
62  nmetaaryl=nmetaaryl,nmetaaryc=nmetaaryc)
63 !
64  fieldsize=(im+2*nframe)*(jm+2*nframe)
65 !
66  call getarg(2,varname)
67  call getarg(3,varlevtyp)
68  call getarg(4,cvarlev)
69  read(cvarlev,'(I3)')varlev
70 !
71 !*** 1: test for var:
72  call nemsio_getheadvar(gfile,trim(varname),ivar,iret=iret)
73  if(iret/=0) then
74  call nemsio_getheadvar(gfile,trim(varname),rvar,iret=iret)
75  if(iret/=0) then
76  call nemsio_getheadvar(gfile,trim(varname),lvar,iret=iret)
77  if(iret/=0) then
78  call nemsio_getheadvar(gfile,trim(varname),cvar,iret=iret)
79  if(iret/=0) then
80  call nemsio_getheadvar(gfile,trim(varname),r8var,iret=iret)
81  if(iret==0) then
82  print *,trim(varname),'=',r8var
83  stop
84  endif
85  else
86  print *,trim(varname),'=',trim(cvar)
87  stop
88  endif
89  else
90  print *,trim(varname),'=',lvar
91  stop
92  endif
93  else
94  print *,trim(varname),'=',rvar
95  stop
96  endif
97  else
98  print *,trim(varname),'=',ivar
99  stop
100  endif
101 
102 !*** 5: test for array:
103 ! *** integer
104 !idate
105  if( trim(varname)=='idate') then
106  call nemsio_getfilehead(gfile,idate=idate,iret=iret)
107  if(iret==0) then
108  print *,'idate=',idate
109  write(odate,'(I4.4,I2.2,I2.2,I2.2)')idate(1),idate(2),idate(3),idate(4)
110  print *,'idate_ymdh=',odate
111  stop
112  endif
113  endif
114 !vcoord
115  if(equal_str_nocase(trim(varname),'vcoord')) then
116  allocate(vcoord(levs+1,3,2))
117  call nemsio_getfilehead(gfile,vcoord=vcoord,iret=iret)
118  if(iret==0) then
119  print *,'levs=',levs,'vcoord(1:levs+1,1,1)=',vcoord(:,1,1)
120  print *,'levs=',levs,'vcoord(1:levs+1,2,1)=',vcoord(:,2,1)
121  print *,'levs=',levs,'vcoord(1:levs+1,3,1)=',vcoord(:,3,1)
122  print *,'levs=',levs,'vcoord(1:levs+1,1,2)=',vcoord(:,1,2)
123  print *,'levs=',levs,'vcoord(1:levs+1,2,2)=',vcoord(:,2,2)
124  print *,'levs=',levs,'vcoord(1:levs+1,3,2)=',vcoord(:,3,2)
125  deallocate(vcoord)
126  stop
127  endif
128  deallocate(vcoord)
129  endif
130 !
131 !recname
132  if(equal_str_nocase(trim(varname),'recname')) then
133  allocate(recname(nrec))
134  call nemsio_getfilehead(gfile,recname=recname,iret=iret)
135  if(iret==0) then
136  print *,'nrec=',nrec,'recname(1:nrec)=',recname
137  deallocate(recname)
138  stop
139  endif
140  deallocate(recname)
141  endif
142 !
143 !reclevtyp
144  if(equal_str_nocase(trim(varname),'reclevtyp')) then
145  allocate(reclevtyp(nrec))
146  call nemsio_getfilehead(gfile,reclevtyp=reclevtyp,iret=iret)
147  if(iret==0) then
148  print *,'nrec=',nrec,'reclevtyp(1:nrec)=',reclevtyp
149  deallocate(reclevtyp)
150  stop
151  endif
152  deallocate(reclevtyp)
153  endif
154 !
155 !reclev
156  if(equal_str_nocase(trim(varname),'reclev')) then
157  allocate(reclev(nrec))
158  call nemsio_getfilehead(gfile,reclev=reclev,iret=iret)
159  if(iret==0) then
160  print *,'nrec=',nrec,'reclev(1:nrec)=',reclev
161  deallocate(reclev)
162  stop
163  endif
164  deallocate(reclev)
165  endif
166 !
167 !lat
168  if(equal_str_nocase(trim(varname),'lat')) then
169  allocate(lat((im+2*nframe)*(jm+2*nframe)))
170  call nemsio_getfilehead(gfile,lat=lat,iret=iret)
171  if(iret==0) then
172  print *,'domainsize=',(im+2*nframe)*(jm+2*nframe),'lat(1:domainsize)=',lat
173  deallocate(lat)
174  stop
175  endif
176  deallocate(lat)
177  endif
178 !
179 !lon
180  if(equal_str_nocase(trim(varname),'lon')) then
181  allocate(lon((im+2*nframe)*(jm+2*nframe)))
182  call nemsio_getfilehead(gfile,lon=lon,iret=iret)
183  if(iret==0) then
184  print *,'domainsize=',(im+2*nframe)*(jm+2*nframe),'lon(1:domainsize)=',lon
185  deallocate(lon)
186  stop
187  endif
188  deallocate(lon)
189  endif
190 !
191 !dx
192  if(equal_str_nocase(trim(varname),'dx')) then
193  allocate(dx((im+2*nframe)*(jm+2*nframe)))
194  call nemsio_getfilehead(gfile,dx=dx,iret=iret)
195  if(iret==0) then
196  print *,'domainsize=',(im+2*nframe)*(jm+2*nframe),'dx(1:domainsize)=',dx
197  deallocate(dx)
198  stop
199  endif
200  deallocate(dx)
201  endif
202 !
203 !dy
204  if(equal_str_nocase(trim(varname),'dy')) then
205  allocate(dy((im+2*nframe)*(jm+2*nframe)))
206  call nemsio_getfilehead(gfile,dy=dy,iret=iret)
207  if(iret==0) then
208  print *,'domainsize=',(im+2*nframe)*(jm+2*nframe),'dy(1:domainsize)=',dy
209  deallocate(dy)
210  stop
211  endif
212  deallocate(dy)
213  endif
214 !
215 !cpi
216  if(equal_str_nocase(trim(varname),'cpi')) then
217  allocate(cpi(ntrac+1))
218  call nemsio_getfilehead(gfile,cpi=cpi,iret=iret)
219  if(iret==0) then
220  print *,'ntrac+1=',ntrac+1,'cpi(1:ntrac+1)=',cpi
221  deallocate(cpi)
222  stop
223  endif
224  deallocate(cpi)
225  endif
226 !
227 !ri
228  if(equal_str_nocase(trim(varname),'ri')) then
229  allocate(ri(ntrac+1))
230  call nemsio_getfilehead(gfile,ri=ri,iret=iret)
231  if(iret==0) then
232  print *,'ntrac+1=',ntrac+1,'ri(1:ntrac+1)=',ri
233  deallocate(ri)
234  stop
235  endif
236  deallocate(ri)
237  endif
238 !
239 !tlmeta
240  if(equal_str_nocase(trim(varname),'tlmeta')) then
241  print *,'tlmeta=',tlmeta
242  stop
243  endif
244 !
245 !file_endian
246  if(equal_str_nocase(trim(varname),'file_endian')) then
247  print *,'file_endian=',file_endian
248  stop
249  endif
250 
251 !int array
252  if(nmetaaryi>0) then
253  allocate(aryiname(nmetaaryi),aryilen(nmetaaryi))
254  call nemsio_getfilehead(gfile,iret=iret,aryiname=aryiname,aryilen=aryilen)
255  Do i=1,nmetaaryi
256 ! if(trim(varname)==aryiname(i)) then
257  if(equal_str_nocase(trim(varname),trim(aryiname(i)))) then
258  j=i
259  call nemsio_getfilehead(gfile, aryilen=aryilen)
260  allocate(iary(aryilen(j)))
261  call nemsio_getheadvar(gfile,trim(varname),iary,iret=iret)
262  if(iret==0) then
263  print *,trim(varname),'(1:',aryilen(j),')=',iary
264  if(equal_str_nocase(trim(varname),"fcstdate")) then
265  write(odate,'(I4.4,I2.2,I2.2,I2.2)')iary(1),iary(2),iary(3),iary(4)
266  print *,'fcstdate_ymdh=',odate
267  endif
268  call nemsio_close(gfile)
269  call nemsio_finalize()
270  stop
271  endif
272  endif
273  enddo
274  endif
275 !
276 ! *** real4
277  if(nmetaaryr>0) then
278  allocate(aryrname(nmetaaryr),aryrlen(nmetaaryr))
279  call nemsio_getfilehead(gfile,iret=iret,aryrname=aryrname,aryrlen=aryrlen)
280  Do i=1,nmetaaryr
281  if(equal_str_nocase(trim(varname),trim(aryrname(i)))) then
282  j=i
283  call nemsio_getfilehead(gfile, aryrlen=aryrlen)
284  allocate(rary(aryrlen(j)))
285  call nemsio_getheadvar(gfile,trim(varname),rary,iret=iret)
286  if(iret==0) then
287  print *,trim(varname),'(1:',aryrlen(j),')=',rary
288  call nemsio_close(gfile)
289  call nemsio_finalize()
290  stop
291  endif
292  endif
293  enddo
294  endif
295 !
296 ! *** real8
297  if(nmetaaryr8>0) then
298  allocate(aryr8name(nmetaaryr8),aryr8len(nmetaaryr8))
299  call nemsio_getfilehead(gfile,iret=iret,aryr8name=aryr8name,aryr8len=aryr8len)
300  Do i=1,nmetaaryr8
301  if(equal_str_nocase(trim(varname),trim(aryr8name(i)))) then
302  j=i
303  call nemsio_getfilehead(gfile, aryr8len=aryr8len)
304  allocate(rary(aryr8len(j)))
305  call nemsio_getheadvar(gfile,trim(varname),rary,iret=iret)
306  if(iret==0) then
307  print *,trim(varname),'(1:',aryr8len(j),')=',rary
308  call nemsio_close(gfile)
309  call nemsio_finalize()
310  stop
311  endif
312  endif
313  enddo
314  endif
315 !
316  if(nmetaaryl>0) then
317  allocate(arylname(nmetaaryl),aryllen(nmetaaryl))
318  call nemsio_getfilehead(gfile,iret=iret,arylname=arylname,aryllen=aryllen)
319  Do i=1,nmetaaryl
320  if(equal_str_nocase(trim(varname),trim(arylname(i)))) then
321  j=i
322  allocate(lary(aryllen(j)))
323  call nemsio_getheadvar(gfile,trim(varname),lary,iret=iret)
324  if(iret==0) then
325  print *,trim(varname),'(1:',aryllen(j),')=',lary
326  call nemsio_close(gfile)
327  call nemsio_finalize()
328  stop
329  endif
330  endif
331  enddo
332  endif
333 !
334  if(nmetaaryc>0) then
335  allocate(arycname(nmetaaryc),aryclen(nmetaaryc))
336  call nemsio_getfilehead(gfile,iret=iret,arycname=arycname,aryclen=aryclen)
337  Do i=1,nmetaaryc
338  if(equal_str_nocase(trim(varname),trim(arycname(i)))) then
339  j=i
340  allocate(cary(aryclen(j)))
341  call nemsio_getheadvar(gfile,trim(varname),cary,iret=iret)
342  if(iret==0) then
343  print *,trim(varname),'(1:',aryclen(j),')=',cary
344  call nemsio_close(gfile)
345  call nemsio_finalize()
346  stop
347  endif
348  endif
349  enddo
350  endif
351 !
352 !
353 !*** 6: test for 2D array:
354  allocate(data(fieldsize))
355  call nemsio_readrecv(gfile,varname,varlevtyp,varlev,data=data,iret=iret)
356  if(iret==0) then
357  print *,'fieldsize=',(im+2*nframe)*(jm+2*nframe),'i=',im+2*nframe
358  do j=1,jm+2*nframe
359  print *,'j=',j,trim(varname),'=',data(1+(j-1)*(im+2*nframe):j*(im+2*nframe))
360  enddo
361 !-- output pure binary file for 1 2D array
362  mystr=trim(varname)//trim(varlevtyp)//trim(cvarlev)
363  filenm=sweep_blanks(mystr)
364  open(991,file=trim(filenm),form='unformatted')
365  write(991) ((data(i+(j-1)*(im+2*nframe)),i=1,im+2*nframe),j=1,jm+2*nframe)
366  close(991)
367 !
368  deallocate(data)
369  call nemsio_close(gfile)
370  call nemsio_finalize()
371  stop
372  endif
373 !
374  call nemsio_close(gfile)
375  call nemsio_finalize()
376 !
377  print *,'no ',trim(varname), ' in the nemsio file!'
378 !
379 ! - - - - -- - -- - -- - -- - - -- - -- -- - -- - -- - - -- - - - -- - --
380  stop
381 
382 !-----------------------------------------------------------------------
383 !
384  end program
385 
386 !-----------------------------------------------------------------------
387 !
388  character(35) function sweep_blanks(in_str)
389 !
390  implicit none
391 !
392  character(*), intent(in) :: in_str
393  character(35) :: out_str
394  character :: ch
395  integer :: j
396 
397  out_str = " "
398  do j=1, len_trim(in_str)
399  ! get j-th char
400  ch = in_str(j:j)
401  if (ch .ne. " ") then
402  out_str = trim(out_str) // ch
403  endif
404  sweep_blanks = out_str
405  end do
406  end function sweep_blanks