source: trunk/mesoscale/LMD_MM_MARS/SRC/WPS/ungrib/src/g1print.F90 @ 87

Last change on this file since 87 was 11, checked in by aslmd, 14 years ago

spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 9.2 KB
Line 
1! Print information about a grib file.
2!  Usage: "gribscan [-v] [-V] filename"
3!  as of now, the filename cannot be a full path name
4!
5program gribscan
6  use module_grib
7  interface
8     subroutine parse_args(err, a1, h1, i1, l1, a2, h2, i2, l2,&
9          a3, h3, i3, l3, hlast)
10       integer :: err
11       character(len=*) , optional :: a1, a2, a3
12       character(len=*), optional :: h1, h2, h3
13       integer , optional :: i1, i2, i3
14       logical, optional :: l1, l2, l3
15       character(len=*), optional :: hlast
16     end subroutine parse_args
17  end interface
18
19  character(len=120) :: flnm
20  character(len=30) :: hopt
21  real, allocatable, dimension(:) :: datarray
22  integer :: ierr, igherr
23  integer :: cc
24  character(len=100) :: fmt = '(I4,1X, &
25       & I3,1x, A5,1x, &
26       & I4, &
27       & 2(1x,I4),2x,I4.4,2("-",I2.2),"_",I2.2,":",&
28       & I2.2, 1x, "+", i2.2)'
29  logical :: ivb = .FALSE.
30  logical :: idb = .FALSE.
31  integer :: year
32  character(len=5) :: gc(255)
33  data gc /'PRES','PRMSL','PTEND','PVORT','ICAHT','GP','HGT','DIST',&
34       'HSTDV','TOZNE','TMP','VTMP','POT','EPOT','T MAX','T MIN','DPT',&
35       'DEPR','LAPR','VIS','RDSP1','RDSP2','RDSP3','PLI','TMP A','PRESA',&
36       'GP A','WVSP1','WVSP2','WVSP3','WDIR','WIND','U GRD','V GRD','STRM',&
37       'V POT','MNTSF','SGCVV','V VEL','DZDT','ABS V','ABD D','REL V','REL D',&
38       'VUCSH','VVCSG','DIR C','SP C','UOGRD','VOGRD','SPF H','R H','MIXR',&
39       'P WAT','VAPP','SAT D','EVP','C ICE','PRATE','TSTM','A PCP','NCPCP',&
40       'ACPCP','SRWEQ','WEASD','SNO D','MIXHT','TTHDP','MTHD','MTH A','T CDC',&
41       'CDCON','L CDC','M CDC','H CDC','C WAT','BLI','SNO C','SNO L','WTMP',&
42       'LAND','DSL M','SFC R','ALBDO','TSOIL','SOILM','VEG','SALTY','DEN',&
43       'WATR','ICE C','ICETK','DICED','SICED','U ICE','V ICE','ICE G','ICE D',&
44       'SNO M','HTSGW','WVDIR','WVHGT','WVPER','SWDIR','SWELL','SWPER','DIRPW',&
45       'PERPW','DIRSW','PERSW','NSWRS','NLWRS','NSWRT','NLWRT','LWAVR','SWAVR',&
46       'GRAD','BRTMP','LWRAD','SWRAD','LHTFL','SHTFL','BLYDP','U FLX','V FLX',&
47       'WMIXE','IMG D',&
48! 128-254 for use by originating center. NWS/NCEP usage is coded here.
49       'MSLSA','MSLMA','MSLET','LFT X','4LFTX','K X','S X','MCONV','VW SH',&
50       'TSLSA','BVF 2','PV MW','CRAIN','CFRZR','CICEP','CSNOW','SOILW',&
51       'PEVPR','CWORK','U-GWD','V-GWD','PV','COVMZ','COVTZ','COVTM','CLWMR',&
52       'O3MR','GFLUX','CIN','CAPE','TKE','CONDP','CSUSF','CSDSF','CSULF',&
53       'CSDLF','CFNSF','CFNLF','VBDSF','VDDSF','NBDSF','NDDSF','RWMR',&
54       'SNMR','M FLX','LMH','LMV','MLYNO','NLAT','ELON','ICMR','GRMR','GUST',&
55       'LPS X','LPS Y','HGT X','HGT Y','TPFI','TIPD','LTNG','RDRIP','VPTMP','HLCY',&
56       'PROB','PROBN','POP','CPOFP','CPOZP','USTM','VSTM','NCIP','EVBS','EVCW',&
57       'ICWAT','CWDI','VAFTD','DSWRF','DLWRF','UVI','MSTAV','SFEXC','MIXLY','TRANS',&
58       'USWRF','ULWRF','CDLYR','CPRAT','TTDIA','TTRAD','TTPHY','PREIX','TSD1D',&
59       'NLGSP','HPBL','5WAVH','CNWAT','SOTYP','VGTYP','BMIXL','AMIXL','PEVAP',&
60       'SNOHF','5WAVA','MFLUX','DTRF','UTRF','BGRUN','SSRUN','SIPD','O3TOT',&
61       'SNOWC','SNOT','COVTW','LRGHR','CNVHR','CNVMR','SHAHR','SHAMR','VDFHR',&
62       'VDFUA','VDFVA','VDFMR','SWHR','LWHR','CD','FRICV','RI','  '/
63
64  flnm = ' '
65  call parse_args(ierr, a1='v', l1=ivb, a2='V', l2=idb, hlast=flnm)
66  if (ierr.ne.0) then
67     call getarg(0, hopt)
68     write(*,'(//,"Usage: ", A, " [-v] [-V] file",/)') trim(hopt)
69     write(*,'("     -v   : Print more information about the GRIB records")')
70     write(*,'("     -V   : Print way too much information about the GRIB&
71          & records")')
72     write(*,'("     file : GRIB file to read"//)')
73      stop
74!    stop
75  endif
76
77  if (idb) ivb = .TRUE.
78
79  call copen(idum, munit, flnm, 1, ierr, 1)
80
81  if (.not. ivb) then
82     write(*,'(52("-"))')
83     write(*,'(" rec GRIB GRIB  Lvl  Lvl  Lvl         Time      Fcst")')
84     write(*,'(" Num Code name  Code one  two                   hour")')
85     write(*,'(52("-"))')
86  endif
87
88  irec = 0
89  call gribget(munit, ierr)
90  do while (ierr.eq.0)
91     irec = irec + 1
92     call gribheader(0,igherr)
93     if (igherr /= 0) then
94        call deallogrib
95        call gribget(munit, ierr)
96        cycle
97     endif
98
99     if ( sec1(3) .ne. 7 ) then  ! gc defined only for NCEP
100       do cc = 128, 254
101         gc(cc) = '     '
102       enddo
103     if ( sec1(3) .eq. 57 ) then  ! AFWA
104       gc(144) = 'DNWLR'
105       gc(145) = 'INSWR'
106       gc(155) = 'GDHFX'
107       gc(157) = 'XTRAJ'
108       gc(158) = 'YTRAJ'
109       gc(159) = 'PTRAJ'
110       gc(160) = 'TERID'
111       gc(161) = 'MDLTN'
112       gc(174) = 'SNOWD'
113       gc(175) = 'SNOAG'
114       gc(176) = 'SNOCL'
115       gc(177) = 'VSBLY'
116       gc(178) = 'CURWX'
117       gc(179) = 'CLAMT'
118       gc(180) = 'CLBAS'
119       gc(181) = 'CLTOP'
120       gc(182) = 'CLTYP'
121       gc(183) = 'UTIME'
122       gc(184) = 'SRCDT'
123       gc(196) = 'EPCDF'
124       gc(197) = 'EPALL'
125       gc(198) = 'EPGEO'
126       gc(199) = 'EPVAL'
127       gc(200) = 'SOILR'
128       gc(201) = 'SOILW'
129       gc(205) = 'TYPSL'
130       gc(206) = 'VLASH'
131       gc(207) = 'CANWT'
132       gc(208) = 'PEVAP'
133       gc(209) = 'WNDRN'
134       gc(210) = 'RHTMN'
135       gc(211) = 'SOILL'
136       gc(212) = 'VEGTP'
137       gc(213) = 'GREEN'
138       gc(234) = 'BGRUN'
139       gc(235) = 'SSRUN'
140     endif
141     endif
142
143     if (ivb) then
144        call gribprint(0)
145        call gribprint(1)
146        call gribprint(2)
147        call gribprint(3)
148        call gribprint(4)
149           if (sec2(4).eq.50) then
150              ndat = (infogrid(1)+1)*(infogrid(2)+1)
151           else
152              ndat = (infogrid(1)*infogrid(2))
153           endif
154           allocate(datarray(ndat))
155           call gribdata(datarray, ndat)
156           fldmax = datarray(1)
157           fldmin = datarray(1)
158           do j = 1, ndat
159             if (datarray(j).gt.fldmax) fldmax=datarray(j)
160             if (datarray(j).lt.fldmin) fldmin=datarray(j)
161           enddo
162        write(*,*) "  "
163        write(*,*) "  ",gc(sec1(7))," : "
164        write(*,'(5x,"Minimum Data Value ",t45,":",g14.5)') fldmin
165        write(*,'(5x,"Maximum Data Value ",t45,":",g14.5)') fldmax
166        write(*,'(//,70("*"))')
167        if (idb) then
168           print*, 'Datarray = ', Datarray
169        endif
170           deallocate(datarray)
171     else
172        CC = sec1(22)
173        year = (cc-1)*100 + sec1(11)
174        write(*,FMT) irec, sec1(7), gc(sec1(7)), sec1(8:10), year,sec1(12:15),sec1(17)
175     endif
176
177     call deallogrib
178
179     call gribget(munit, ierr)
180  enddo
181  if (ierr.eq.1) write(*,'(/,"***** End-Of-File on C unit ", I3,/)') munit
182  call cclose( munit, 0, ierr)
183
184end program gribscan
185
186subroutine parse_args(err, a1, h1, i1, l1, a2, h2, i2, l2, a3, h3, i3, l3, &
187     hlast)
188  integer :: err
189  character(len=*) , optional :: a1, a2, a3
190  character(len=*), optional :: h1, h2, h3
191  integer , optional :: i1, i2, i3
192  logical, optional :: l1, l2, l3
193  character(len=*), optional :: hlast
194
195  character(len=100) :: hold
196  integer :: ioff = 0
197
198  if (present(hlast)) then
199     ioff = -1
200  endif
201
202  err = 0
203
204  narg = iargc()
205  numarg = narg + ioff
206
207  i = 1
208  LOOP : do while ( i <= numarg)
209
210     ierr = 1
211     if (present(i1)) then
212        call checkiarg(i, a1, i1, ierr)
213     elseif (present(h1)) then
214        call checkharg(i, a1, h1, ierr)
215     elseif (present(l1)) then
216        call checklarg(i, a1, l1, ierr)
217     endif
218     if (ierr.eq.0) cycle LOOP
219
220     if (present(i2)) then
221        call checkiarg(i, a2, i2, ierr)
222     elseif (present(h2)) then
223        call checkharg(i, a2, h2, ierr)
224     elseif (present(l2)) then
225        call checklarg(i, a2, l2, ierr)
226     endif
227     if (ierr.eq.0) cycle LOOP
228
229     if (present(i3)) then
230        call checkiarg(i, a3, i3, ierr)
231     elseif (present(h3)) then
232        call checkharg(i, a3, h3, ierr)
233     elseif (present(l3)) then
234        call checklarg(i, a3, l3, ierr)
235     endif
236     if (ierr.eq.0) cycle LOOP
237
238     err = 1
239     call getarg(1, hold)
240     write(*, '("arg = ", A)') trim(hold)
241
242     exit LOOP
243
244  enddo LOOP
245
246  if (present(hlast)) then
247     if (narg.eq.0) then
248        err = 1
249     else
250        call getarg(narg, hlast)
251     endif
252  endif
253
254contains
255  subroutine checkiarg(c, a, i, ierr)
256    integer :: c
257    character(len=*) :: a
258    integer :: i
259
260    character(len=100) :: hold
261    ierr = 1
262
263    call getarg(c, hold)
264
265    if ('-'//a.eq.trim(hold)) then
266       c = c + 1
267       call getarg(c, hold)
268       read(hold, *) i
269       c = c + 1
270       ierr = 0
271    elseif ('-'//a .eq. hold(1:len_trim(a)+1)) then
272       hold = hold(len_trim(a)+2: len(hold))
273       read(hold, *) i
274       c = c + 1
275       ierr = 0
276    endif
277       
278  end subroutine checkiarg
279  subroutine checkharg(c, a, h, ierr)
280    integer :: c
281    character(len=*) :: a
282    character(len=*) :: h
283
284    character(len=100) :: hold
285    ierr = 1
286
287    call getarg(c, hold)
288
289    if ('-'//a.eq.trim(hold)) then
290       c = c + 1
291       call getarg(c, hold)
292       h = trim(hold)
293       c = c + 1
294       ierr = 0
295    elseif ('-'//a .eq. hold(1:len_trim(a)+1)) then
296       hold = hold(len_trim(a)+2: len(hold))
297       h = trim(hold)
298       c = c + 1
299       ierr = 0
300    endif
301       
302  end subroutine checkharg
303
304  subroutine checklarg(c, a, l, ierr)
305    integer :: c
306    character(len=*) :: a
307    logical :: l
308
309    character(len=100) :: hold
310    ierr = 1
311
312    call getarg(c, hold)
313    if ('-'//a.eq.trim(hold)) then
314       l = .TRUE.
315       c = c + 1
316       ierr = 0
317    endif
318       
319  end subroutine checklarg
320
321end subroutine parse_args
322
323
Note: See TracBrowser for help on using the repository browser.