SCALE-RM
scale_file_grads.F90
Go to the documentation of this file.
1 !-------------------------------------------------------------------------------
10 #include "scalelib.h"
11 module scale_file_grads
12  !-----------------------------------------------------------------------------
13  !
14  !++ used modules
15  !
16  use scale_precision
17  use scale_io
18  use scale_prof
19  !-----------------------------------------------------------------------------
20  implicit none
21  private
22  !-----------------------------------------------------------------------------
23  !
24  !++ Public procedure
25  !
26  public :: file_grads_finalize
27  public :: file_grads_open
28  public :: file_grads_varid
29  public :: file_grads_varcheck
30  public :: file_grads_isoned
31  public :: file_grads_get_shape
32  public :: file_grads_read
33  public :: file_grads_close
34 
35  interface file_grads_get_shape
36  module procedure file_grads_get_shape_name
37  module procedure file_grads_get_shape_id
38  end interface file_grads_get_shape
39 
40  interface file_grads_read
41  module procedure file_grads_read_1d_name
42  module procedure file_grads_read_1d_id
43  module procedure file_grads_read_2d_name
44  module procedure file_grads_read_2d_id
45  module procedure file_grads_read_3d_name
46  module procedure file_grads_read_3d_id
47  end interface file_grads_read
48  !-----------------------------------------------------------------------------
49  !
50  !++ Public parameters & variables
51  !
52  !-----------------------------------------------------------------------------
53  !
54  !++ Private procedure
55  !
56  !-----------------------------------------------------------------------------
57  !
58  !++ Private parameters & variables
59  !
60  integer, parameter :: nmls_max = 10
61  integer, parameter :: vars_max = 100
62  integer, parameter :: lvars_max = 1000
63  type t_var
64  character(len=H_SHORT) :: name
65  character(len=H_LONG) :: fname
66  character(len=H_SHORT) :: dtype
67  real(RP) :: swpoint
68  real(RP) :: dd
69  integer :: lnum
70  real(RP), allocatable :: lvars(:)
71  integer :: startrec
72  integer :: totalrec
73  real(SP) :: missval
74  integer :: nx
75  integer :: ny
76  integer :: nz
77  logical :: yrev
78  integer :: endian ! 0: little, 1: big
79  character(len=H_SHORT) :: bintype
80  end type t_var
81  type t_nml
82  character(len=H_LONG) :: fname
83  integer :: nx, ny, nz
84  type(t_var), allocatable :: vars(:)
85  integer :: nvars
86  end type t_nml
87  type t_file
88  character(len=H_LONG) :: fname
89  character(len=H_SHORT) :: postfix
90  integer :: fid
91  end type t_file
92  type(t_nml), save :: nmls(nmls_max)
93  integer :: nnmls = 0
94  type(t_file) :: files(vars_max)
95  integer :: nfiles = 0
96 
97  !-----------------------------------------------------------------------------
98 contains
99  !-----------------------------------------------------------------------------
101  subroutine file_grads_open( &
102  file_name, &
103  file_id )
104  use scale_prc, only: &
105  prc_abort
106  use scale_const, only: &
107  undef => const_undef
108  implicit none
109  character(len=*), intent(in) :: file_name
110  integer, intent(out) :: file_id
111 
112  character(len=H_SHORT) :: name ! up to 16 characters
113  character(len=H_SHORT) :: dtype ! 'linear','levels','map'
114  character(len=H_LONG) :: fname ! head of file name
115  real(rp) :: swpoint ! start point (south-west point) for "linear"
116  real(rp) :: dd ! dlon,dlat for "linear"
117  integer :: lnum ! number of data
118  real(rp) :: lvars(lvars_max) ! values for "levels"
119  integer :: startrec ! record position
120  integer :: totalrec ! total record number per one time
121  real(sp) :: missval ! missing value
122  integer :: nx ! optional
123  integer :: ny ! optional
124  integer :: nz ! optional
125  character(len=H_SHORT) :: fendian ! option for "map"
126  logical :: yrev ! option for "map", if yrev=.true., order of data is NW to SE.
127  character(len=H_SHORT) :: bintype ! binary type: 'int?' or 'real?' ?=2,4, or 8
128 
129  namelist /grads_dims/ &
130  nx, &
131  ny, &
132  nz
133 
134  namelist /grads_item/ &
135  name, & ! necessary
136  dtype, & ! necessary
137  fname, & ! necessary except for linear data
138  swpoint, & ! for linear data
139  dd, & ! for linear data
140  lnum, & ! for levels data
141  lvars, & ! for levels data
142  startrec, & ! for map data
143  totalrec, & ! for map data
144  missval, & ! option
145  nx, & ! option
146  ny, & ! option
147  nz, & ! option
148  yrev, & ! option
149  bintype ! option
150 ! fendian ! option
151 
152  character(len=H_LONG) :: dirname
153 
154  integer :: fid
155  integer :: nvars
156  integer :: ierr
157  integer :: n
158  !---------------------------------------------------------------------------
159 
160  call io_get_fname(fname, file_name)
161 
162  log_newline
163  log_info("FILE_GrADS_open",*) 'open namelist file :', trim(fname)
164 
165  ! check exist
166  do n = 1, nnmls
167  if ( nmls(n)%fname == fname ) then
168  ! alread read
169  file_id = n
170  return
171  end if
172  end do
173 
174 
175  fid = io_get_available_fid()
176  !--- open namelist
177  open( fid, &
178  file = fname, &
179  form = 'formatted', &
180  status = 'old', &
181  action = 'read', &
182  iostat = ierr )
183  if ( ierr /= 0 ) then
184  log_error("FILE_GrADS_open",*) 'Input file is not found! ', trim(fname)
185  call prc_abort
186  endif
187 
188  call check_oldnamelist( fid )
189 
190  !--- read namelist dims
191  read(fid,nml=grads_dims,iostat=ierr)
192  if( ierr /= 0 ) then !--- missing or fatal error
193  log_error("FILE_GrADS_open",*) 'Not appropriate names in GrADS_DIMS in ', trim(fname),'. Check!'
194  call prc_abort
195  endif
196  log_nml(grads_dims)
197 
198 
199  nnmls = nnmls + 1
200  if ( nnmls > nmls_max ) then
201  log_error("FILE_GrADS_open",*) 'Number of GrADS file to be open is exceeded the maximum', nmls_max
202  call prc_abort
203  end if
204  file_id = nnmls
205 
206  nmls(file_id)%fname = file_name
207  nmls(file_id)%nx = nx
208  nmls(file_id)%ny = ny
209  nmls(file_id)%nz = nz
210 
211 
212 
213  !--- count the number of variables
214  rewind(fid)
215  nvars = 0
216  do n = 1, vars_max
217  read(fid, nml=grads_item, iostat=ierr)
218  if( ierr > 0 )then
219  log_error("FILE_GrADS_open",*) 'Not appropriate names in GrADS_ITEM in ', trim(file_name),'. Check!'
220  call prc_abort
221  else if( ierr < 0 )then
222  exit
223  endif
224  nvars = nvars + 1
225  enddo
226 
227  if ( nvars > vars_max ) then
228  log_error("FILE_GRADS_open",*) 'The number of grads vars exceeds the limit! ', &
229  nvars, ' > ', vars_max
230  call prc_abort
231  endif
232 
233  nmls(file_id)%nvars = nvars
234  allocate( nmls(file_id)%vars(nvars) )
235 
236  n = index( file_name, '/', back=.true. )
237  if ( n > 0 ) then
238  dirname = file_name(1:n)
239  else
240  dirname = ""
241  end if
242 
243  !--- read information of the variables
244  rewind(fid)
245  do n = 1, nvars
246 
247  ! set default
248  name = ''
249  dtype = ''
250  fname = ''
251  swpoint = undef
252  dd = undef
253  lnum = -1
254  lvars(:) = undef
255  startrec = -1
256  totalrec = -1
257  nx = nmls(file_id)%nx
258  ny = nmls(file_id)%ny
259  nz = nmls(file_id)%nz
260  yrev = .false.
261  fendian = 'big'
262  missval = undef
263  bintype = 'real4'
264 
265  ! read namelist
266  read(fid, nml=grads_item, iostat=ierr)
267  if( ierr /= 0 ) exit
268 
269  nmls(file_id)%vars(n)%name = upcase(name)
270  if ( fname(1:1) == "/" ) then
271  nmls(file_id)%vars(n)%fname = fname
272  else
273  nmls(file_id)%vars(n)%fname = trim(dirname) // fname
274  end if
275  nmls(file_id)%vars(n)%dtype = dtype
276  nmls(file_id)%vars(n)%swpoint = swpoint
277  nmls(file_id)%vars(n)%dd = dd
278  nmls(file_id)%vars(n)%lnum = lnum
279  if ( lnum > 0 ) then
280  if ( lnum > lvars_max ) then
281  log_error("FILE_GrADS_open",*) 'lnum exceeds the limit', lvars_max
282  call prc_abort
283  end if
284  allocate( nmls(file_id)%vars(n)%lvars(lnum) )
285  nmls(file_id)%vars(n)%lvars(:) = lvars(1:lnum)
286  end if
287  nmls(file_id)%vars(n)%startrec = startrec
288  nmls(file_id)%vars(n)%totalrec = totalrec
289  nmls(file_id)%vars(n)%missval = missval
290  nmls(file_id)%vars(n)%nx = nx
291  nmls(file_id)%vars(n)%ny = ny
292  nmls(file_id)%vars(n)%nz = nz
293  nmls(file_id)%vars(n)%yrev = yrev
294  if ( fendian == "big" ) then
295  nmls(file_id)%vars(n)%endian = 1
296  else
297  nmls(file_id)%vars(n)%endian = 0
298  end if
299  nmls(file_id)%vars(n)%bintype = bintype
300 
301  end do
302 
303  close( fid )
304 
305  end subroutine file_grads_open
306 
307  !-----------------------------------------------------------------------------
308  subroutine file_grads_varid( &
309  file_id, &
310  var_name, &
311  var_id )
312  use scale_prc, only: &
313  prc_abort
314  implicit none
315  integer, intent(in) :: file_id
316  character(len=*), intent(in) :: var_name
317  integer, intent(out) :: var_id
318 
319  character(len=len(var_name)) :: vname
320  integer :: n
321 
322  if ( file_id < 0 ) then
323  log_error("FILE_GrADS_varid",*) 'file_id is invalid: ', file_id
324  call prc_abort
325  end if
326 
327  vname = upcase(var_name)
328 
329  var_id = -1
330  do n = 1, nmls(file_id)%nvars
331  if ( nmls(file_id)%vars(n)%name == vname ) then
332  var_id = n
333  return
334  end if
335  end do
336 
337  return
338  end subroutine file_grads_varid
339 
340  subroutine file_grads_varcheck( &
341  file_id, &
342  var_name, &
343  exist )
344  use scale_prc, only: &
345  prc_abort
346  implicit none
347  integer, intent(in) :: file_id
348  character(len=*), intent(in) :: var_name
349  logical, intent(out) :: exist
350 
351  integer :: var_id
352 
353  if ( file_id < 0 ) then
354  log_error("FILE_GrADS_varcheck",*) 'file_id is invalid: ', file_id
355  call prc_abort
356  end if
357 
358  exist = .true.
359 
360  call file_grads_varid( file_id, var_name, & ! (in)
361  var_id ) ! (out)
362  if ( var_id < 0 ) then
363  exist = .false.
364  end if
365 
366  return
367  end subroutine file_grads_varcheck
368 
369  function file_grads_isoned( &
370  file_id, &
371  var_id ) &
372  result(ret)
373  use scale_prc, only: &
374  prc_abort
375  implicit none
376  integer, intent(in) :: file_id
377  integer, intent(in) :: var_id
378  logical :: ret
379 
380  if ( file_id < 0 ) then
381  log_error("FILE_GrADS_isOneD",*) 'file_id is invalid: ', file_id
382  call prc_abort
383  end if
384  if ( var_id < 0 ) then
385  log_error("FILE_GrADS_isOneD",*) 'var_id is invalid: ', var_id
386  call prc_abort
387  end if
388 
389  select case( nmls(file_id)%vars(var_id)%dtype )
390  case ('linear', 'levels')
391  ret = .true.
392  case default
393  ret = .false.
394  end select
395 
396  return
397  end function file_grads_isoned
398 
399  !-----------------------------------------------------------------------------
400  subroutine file_grads_get_shape_name( &
401  file_id, &
402  var_name, &
403  shape )
404  use scale_prc, only: &
405  prc_abort
406  implicit none
407  integer, intent(in) :: file_id
408  character(len=*), intent(in) :: var_name
409  integer, intent(out) :: shape(:)
410 
411  integer :: var_id
412 
413  call file_grads_varid( file_id, var_name, & ! (in)
414  var_id ) ! (out)
415 
416  if ( var_id < 0 ) then
417  log_error("FILE_GrADS_get_shape",*) 'variable "', trim(var_name), ' is not founed in file "', trim(nmls(file_id)%fname), '"'
418  call prc_abort
419  end if
420 
421  call file_grads_get_shape_id( file_id, var_id, & ! (in)
422  shape(:) ) ! (out)
423 
424  return
425  end subroutine file_grads_get_shape_name
426  !-----------------------------------------------------------------------------
427  subroutine file_grads_get_shape_id( &
428  file_id, &
429  var_id, &
430  shape )
431  implicit none
432  integer, intent(in) :: file_id
433  integer, intent(in) :: var_id
434  integer, intent(out) :: shape(:)
435 
436  intrinsic :: size
437 
438  if ( file_grads_isoned( file_id, var_id ) ) then
439  if ( nmls(file_id)%vars(var_id)%dtype == "levels" ) then
440  shape(1) = nmls(file_id)%vars(var_id)%lnum
441  else
442  shape(1) = -1
443  end if
444  else if ( size(shape) == 2 ) then
445  shape(1) = nmls(file_id)%vars(var_id)%nx
446  shape(2) = nmls(file_id)%vars(var_id)%ny
447  else
448  shape(1) = nmls(file_id)%vars(var_id)%nz
449  shape(2) = nmls(file_id)%vars(var_id)%nx
450  shape(3) = nmls(file_id)%vars(var_id)%ny
451  end if
452 
453  return
454  end subroutine file_grads_get_shape_id
455 
456  !-----------------------------------------------------------------------------
457  subroutine file_grads_read_1d_name( &
458  file_id, &
459  var_name, &
460  var, &
461  step, &
462  start, &
463  count, &
464  postfix )
465  use scale_prc, only: &
466  prc_abort
467  implicit none
468  integer, intent(in) :: file_id
469  character(len=*), intent(in) :: var_name
470  real(RP), intent(out) :: var(:)
471  integer, intent(in), optional :: step
472  integer, intent(in), optional :: start(1)
473  integer, intent(in), optional :: count(1)
474  character(len=*), intent(in), optional :: postfix
475 
476  integer :: var_id
477  !---------------------------------------------------------------------------
478 
479  call file_grads_varid( file_id, var_name, & ! (in)
480  var_id ) ! (out)
481 
482  if ( var_id < 0 ) then
483  log_error("FILE_GrADS_read_1D_name",*) 'variable "', trim(var_name), ' is not founed in file "', trim(nmls(file_id)%fname), '"'
484  call prc_abort
485  end if
486 
487 
488  call file_grads_read_1d_id( file_id, var_id, & ! (in)
489  var(:), & ! (out)
490  step = step, & ! (in)
491  start = start, & ! (in)
492  count = count, & ! (in)
493  postfix = postfix ) ! (in)
494 
495  return
496  end subroutine file_grads_read_1d_name
497  !-----------------------------------------------------------------------------
498  subroutine file_grads_read_1d_id( &
499  file_id, &
500  var_id, &
501  var, &
502  step, &
503  start, &
504  count, &
505  postfix )
506  implicit none
507  integer, intent(in) :: file_id
508  integer, intent(in) :: var_id
509  real(RP), intent(out) :: var(:)
510  integer, intent(in), optional :: step
511  integer, intent(in), optional :: start(1)
512  integer, intent(in), optional :: count(1)
513  character(len=*), intent(in), optional :: postfix
514 
515  logical :: exist
516  integer :: vid
517 
518  intrinsic :: size
519  !---------------------------------------------------------------------------
520 
521  if ( file_id < 0 ) then
522  log_error("FILE_GrADS_read_1D_vid",*) 'file_id is invalid: ', file_id
523  end if
524  if ( var_id < 0 ) then
525  log_error("FILE_GrADS_read_1D_vid",*) 'var_id is invalid: ', var_id
526  end if
527 
528  call file_grads_read_data( nmls(file_id)%vars(var_id), & ! (in)
529  1, size(var), shape(var), & ! (in)
530  var(:), & ! (out)
531  step = step, & ! (int)
532  start = start, & ! (int)
533  count = count, & ! (int)
534  postfix = postfix ) ! (in)
535 
536  return
537  end subroutine file_grads_read_1d_id
538 
539  !-----------------------------------------------------------------------------
540  subroutine file_grads_read_2d_name( &
541  file_id, &
542  var_name, &
543  var, &
544  step, &
545  start, &
546  count, &
547  postfix )
548  use scale_prc, only: &
549  prc_abort
550  implicit none
551  integer, intent(in) :: file_id
552  character(len=*), intent(in) :: var_name
553  real(RP), intent(out) :: var(:,:)
554  integer, intent(in), optional :: step
555  integer, intent(in), optional :: start(2)
556  integer, intent(in), optional :: count(2)
557  character(len=*), intent(in), optional :: postfix
558 
559  integer :: var_id
560  !---------------------------------------------------------------------------
561 
562  call file_grads_varid( file_id, var_name, & ! (in)
563  var_id ) ! (out)
564 
565  if ( var_id < 0 ) then
566  log_error("FILE_GrADS_read_2D_name",*) 'variable "', trim(var_name), ' is not founed in file "', trim(nmls(file_id)%fname), '"'
567  call prc_abort
568  end if
569 
570  call file_grads_read_2d_id( file_id, var_id, & ! (in)
571  var(:,:), & ! (out)
572  step = step, & ! (in)
573  start = start, & ! (in)
574  count = count, & ! (in)
575  postfix = postfix ) ! (in)
576 
577  return
578  end subroutine file_grads_read_2d_name
579  !-----------------------------------------------------------------------------
580  subroutine file_grads_read_2d_id( &
581  file_id, &
582  var_id, &
583  var, &
584  step, &
585  start, &
586  count, &
587  postfix )
588  implicit none
589  integer, intent(in) :: file_id
590  integer, intent(in) :: var_id
591  real(RP), intent(out) :: var(:,:)
592  integer, intent(in), optional :: step
593  integer, intent(in), optional :: start(2)
594  integer, intent(in), optional :: count(2)
595  character(len=*), intent(in), optional :: postfix
596 
597  integer :: vid
598  intrinsic :: size
599  !---------------------------------------------------------------------------
600 
601  if ( file_id < 0 ) then
602  log_error("FILE_GrADS_read_2D_vid",*) 'file_id is invalid: ', file_id
603  end if
604  if ( var_id < 0 ) then
605  log_error("FILE_GrADS_read_2D_vid",*) 'var_id is invalid: ', var_id
606  end if
607 
608  call file_grads_read_data( nmls(file_id)%vars(var_id), & ! (in)
609  2, size(var), shape(var), & ! (in)
610  var(:,:), & ! (out)
611  step = step, & ! (in)
612  start = start, & ! (in)
613  count = count, & ! (in)
614  postfix = postfix ) ! (in)
615 
616  return
617  end subroutine file_grads_read_2d_id
618 
619  !-----------------------------------------------------------------------------
620  subroutine file_grads_read_3d_name( &
621  file_id, &
622  var_name, &
623  var, &
624  step, &
625  start, &
626  count, &
627  postfix )
628  use scale_prc, only: &
629  prc_abort
630  implicit none
631  integer, intent(in) :: file_id
632  character(len=*), intent(in) :: var_name
633  real(RP), intent(out) :: var(:,:,:)
634  integer, intent(in), optional :: step
635  integer, intent(in), optional :: start(3)
636  integer, intent(in), optional :: count(3)
637  character(len=*), intent(in), optional :: postfix
638 
639  integer :: var_id
640  !---------------------------------------------------------------------------
641 
642  call file_grads_varid( file_id, var_name, & ! (in)
643  var_id ) ! (out)
644 
645  if ( var_id < 0 ) then
646  log_error("FILE_GrADS_read_3D_name",*) 'variable "', trim(var_name), ' is not founed in file "', trim(nmls(file_id)%fname), '"'
647  call prc_abort
648  end if
649 
650  call file_grads_read_3d_id( file_id, var_id, & ! (in)
651  var(:,:,:), & ! (out)
652  step = step, & ! (in)
653  start = start, & ! (in)
654  count = count, & ! (in)
655  postfix = postfix ) ! (in)
656 
657  return
658  end subroutine file_grads_read_3d_name
659  !-----------------------------------------------------------------------------
660  subroutine file_grads_read_3d_id( &
661  file_id, &
662  var_id, &
663  var, &
664  step, &
665  start, &
666  count, &
667  postfix )
668  implicit none
669  integer, intent(in) :: file_id
670  integer, intent(in) :: var_id
671  real(RP), intent(out) :: var(:,:,:)
672  integer, intent(in), optional :: step
673  integer, intent(in), optional :: start(3)
674  integer, intent(in), optional :: count(3)
675  character(len=*), intent(in), optional :: postfix
676 
677  integer :: vid
678  intrinsic :: size
679  !---------------------------------------------------------------------------
680 
681  if ( file_id < 0 ) then
682  log_error("FILE_GrADS_read_3D_vid",*) 'file_id is invalid: ', file_id
683  end if
684  if ( var_id < 0 ) then
685  log_error("FILE_GrADS_read_3D_vid",*) 'var_id is invalid: ', var_id
686  end if
687 
688  call file_grads_read_data( nmls(file_id)%vars(var_id), & ! (in)
689  3, size(var), shape(var), & ! (in)
690  var(:,:,:), & ! (out)
691  step = step, & ! (in)
692  start = start, & ! (in)
693  count = count, & ! (in)
694  postfix = postfix ) ! (in)
695 
696  return
697  end subroutine file_grads_read_3d_id
698 
699  subroutine file_grads_finalize
700  integer :: n
701 
702  do n = 1, nnmls
703  call file_grads_close(n)
704  end do
705  nnmls = 0
706 
707  return
708  end subroutine file_grads_finalize
709 
710  !-----------------------------------------------------------------------------
711  subroutine file_grads_close( &
712  file_id )
713  implicit none
714  integer, intent(in) :: file_id
715 
716  integer :: n, m
717 
718  if ( file_id < 0 ) return
719 
720  do n = 1, nmls(file_id)%nvars
721  do m = 1, nfiles
722  if ( files(m)%fname == nmls(file_id)%vars(n)%fname ) then
723  if ( files(m)%fid > 0 ) then
724  close( files(m)%fid )
725  files(m)%fid = -1
726  files(m)%postfix = ""
727  end if
728  exit
729  end if
730  end do
731  if ( nmls(file_id)%vars(n)%lnum > 0 ) deallocate( nmls(file_id)%vars(n)%lvars )
732  nmls(file_id)%vars(n)%lnum = -1
733  end do
734  deallocate( nmls(file_id)%vars )
735  nmls(file_id)%fname = ""
736  nmls(file_id)%nvars = 0
737 
738  return
739  end subroutine file_grads_close
740 
741  !-----------------------------------------------------------------------------
742  ! private
743  !-----------------------------------------------------------------------------
744 
745  subroutine file_grads_read_data( &
746  var_info, &
747  ndims, n, &
748  shape, &
749  var, &
750  step, &
751  start, &
752  count, &
753  postfix )
754  use scale_prc, only: &
755  prc_abort
756  use scale_const, only: &
757  undef => const_undef, &
758  eps => const_eps
759  implicit none
760  type(t_var), intent(in) :: var_info
761  integer, intent(in) :: ndims
762  integer, intent(in) :: n
763  integer, intent(in) :: shape(ndims)
764  real(rp), intent(out) :: var(n)
765  integer, intent(in), optional :: step
766  integer, intent(in), optional :: start(ndims)
767  integer, intent(in), optional :: count(ndims)
768  character(len=*), intent(in), optional :: postfix
769 
770  integer :: fid
771  character(len=H_LONG) :: gfile
772  real(sp) :: buf(var_info%nx,var_info%ny)
773 
774  integer :: step_
775  integer :: start_(3)
776  integer :: count_(3)
777  character(len=H_SHORT) :: postfix_
778 
779  integer :: nxy, nz, ka
780  integer :: pos, isize, ierr
781  integer :: i, j, k, ii, jj, kk
782 
783  abstract interface
784  subroutine rd( fid, pos, nx, cz, k, sx, cx, cy, yrev, var, ierr )
785  use scale_precision
786  integer, intent(in) :: fid, pos
787  integer, intent(in) :: nx, cz, k, sx, cx, cy
788  logical, intent(in) :: yrev
789  real(rp), intent(out) :: var(:)
790  integer, intent(out) :: ierr
791  end subroutine rd
792  end interface
793  procedure(rd), pointer :: read_data
794 
795  select case( var_info%dtype )
796  case("linear")
797 
798  if ( ndims > 1 ) then
799  log_error("FILE_GrADS_read_data",*) '"linear" is invalid for dtype of 2D or 2D var!'
800  end if
801 
802  if( var_info%swpoint == undef .or.var_info%dd == undef ) then
803  log_error("FILE_GrADS_read_data",*) '"swpoint" and "dd" are required for linear data! ', var_info%swpoint
804  call prc_abort
805  endif
806 
807  if ( present(start) ) then
808  start_(1) = start(1)
809  else
810  start_(1) = 1
811  end if
812  if ( present(count) ) then
813  count_(1) = count(1)
814  else
815  count_(1) = n - start_(1) + 1
816  end if
817 
818  do i = 1, count_(1)
819  ii = i + start_(1) - 2 ! from 0
820  var(i) = var_info%swpoint + ii * var_info%dd
821  end do
822 
823  case("levels")
824 
825  if ( ndims > 1 ) then
826  log_error("FILE_GrADS_read_data",*) '"levels" is invalid for dtype of 2D or 2D var!'
827  end if
828 
829  if ( var_info%lnum < 0 )then
830  log_error("FILE_GrADS_read_data",*) '"lnum" is required for levels data! '
831  call prc_abort
832  endif
833  if ( var_info%lnum .ne. n ) then
834  log_error("FILE_GrADS_read_data",*) '"lnum" and size of var are not the same', var_info%lnum, n
835  call prc_abort
836  end if
837 
838  if ( present(start) ) then
839  start_(1) = start(1)
840  else
841  start_(1) = 1
842  end if
843  if ( present(count) ) then
844  count_(1) = count(1)
845  else
846  count_(1) = var_info%lnum - start_(1) + 1
847  end if
848 
849  do k = 1, count_(1)
850  kk = k + start_(1) - 1
851  if ( kk > var_info%lnum ) exit
852  var(k) = var_info%lvars(kk)
853  if( var(k) == undef ) then
854  log_error("FILE_GrADS_read_data",*) '"lvars" must be specified for levels data! '
855  call prc_abort
856  endif
857  end do
858 
859  case("map")
860 
861  if ( present(postfix) ) then
862  postfix_ = postfix
863  else
864  postfix_ = ""
865  end if
866  if ( present(step) ) then
867  step_ = step
868  else
869  step_ = 1
870  end if
871 
872  if ( ndims == 1 ) then
873  log_error("FILE_GrADS_read_data",*) '"map" is invalid for dtype of 1D var!'
874  end if
875 
876  if( var_info%startrec < 0 .or. var_info%totalrec < 0 )then
877  log_error("FILE_GrADS_read_data",*) '"startrec" and "totalrec" are required for map data! ', var_info%startrec, var_info%totalrec
878  call prc_abort
879  endif
880  if( var_info%fname == "" )then
881  log_error("FILE_GrADS_read_data",*) '"fname" is required for map data!'
882  call prc_abort
883  endif
884 
885  ! get file_id
886  fid = -1
887  do i = 1, nfiles
888  if ( files(i)%fname == var_info%fname ) then
889  fid = i
890  exit
891  end if
892  end do
893  if ( fid < 0 ) then
894  nfiles = nfiles + 1
895  if ( nfiles > vars_max ) then
896  log_error("FILE_GrADS_read_data",*) 'The number of files exceeds the limit', vars_max
897  call prc_abort
898  end if
899  fid = nfiles
900  files(fid)%fname = var_info%fname
901  files(fid)%postfix = ""
902  files(fid)%fid = -1
903  end if
904 
905  call io_get_fname(gfile, trim(var_info%fname)//trim(postfix_)//'.grd')
906 
907  if ( files(fid)%postfix == postfix_ .and. files(fid)%fid > 0 ) then
908  fid = files(fid)%fid
909  else
910  if ( files(fid)%fid > 0 ) close( files(fid)%fid )
911  files(fid)%fid = io_get_available_fid()
912  files(fid)%postfix = postfix_
913  fid = files(fid)%fid
914  open( fid, &
915  file = gfile, &
916  form = 'unformatted', &
917  access = 'stream', &
918  status = 'old', &
919  iostat = ierr )
920  if ( ierr /= 0 ) then
921  log_error("FILE_GrADS_read_data",*) 'Failed to open the grads data file! ', trim(gfile)
922  call prc_abort
923  end if
924  end if
925 
926  if ( ndims == 2 ) then
927  nz = 1
928  ka = 1
929  start_(1) = 1
930  if ( present(start) ) then
931  start_(2:3) = start(:)
932  else
933  start_(2:3) = 1
934  end if
935  count_(1) = 1
936  if ( present(count) ) then
937  count_(2:3) = count(:)
938  else
939  count_(2:3) = (/ var_info%nx, var_info%ny /)
940  end if
941  if ( shape(1) .ne. count_(2) .or. shape(2) .ne. count_(3) ) then
942  log_error("FILE_GrADS_read_data",*) 'nx or ny is different', shape(:), count_(2:3)
943  call prc_abort
944  end if
945  else
946  nz = var_info%nz
947  ka = shape(1)
948  if ( present(start) ) then
949  start_(:) = start(:)
950  else
951  start_(:) = 1
952  end if
953  if ( present(count) ) then
954  count_(:) = count(:)
955  else
956  count_(:) = (/ nz, var_info%nx, var_info%ny /)
957  end if
958  if ( ka < count_(1) ) then
959  log_error("FILE_GrADS_read_data",*) 'size is too small for the 1st dimension'
960  call prc_abort
961  end if
962  if ( shape(2) .ne. count_(2) .or. shape(3) .ne. count_(3) ) then
963  log_error("FILE_GrADS_read_data",*) 'nx or ny is different', shape(2:), count_(2:)
964  call prc_abort
965  end if
966  count_(1) = min( count_(1), nz )
967  end if
968  nxy = count_(2) * count_(3)
969 
970 
971  if ( n .ne. nxy * ka ) then
972  log_error("FILE_GrADS_read_data",*) 'size of var is not consitent with namelist info! ', n, ka, count_(2:3)
973  call prc_abort
974  end if
975 
976  select case ( var_info%bintype )
977  case ( 'int1' )
978  read_data => read_data_int1
979  isize = 1
980  case ( 'int2' )
981  read_data => read_data_int2
982  isize = 2
983  case ( 'int4' )
984  read_data => read_data_int4
985  isize = 4
986  case ( 'real4' )
987  read_data => read_data_real4
988  isize = 4
989  case ( 'int8' )
990  read_data => read_data_int8
991  isize = 8
992  case ( 'real8' )
993  read_data => read_data_real8
994  isize = 8
995  case default
996  log_error("FILE_GrADS_read_data",*) 'bintype is invalid for ', trim(var_info%name)
997  end select
998 
999  do k = 1, count_(1)
1000  kk = k + start_(1) - 2 ! from 0
1001  pos = ( var_info%totalrec * ( step_ - 1 ) + var_info%startrec - 1 + kk ) * var_info%ny
1002  if ( var_info%yrev ) then
1003  pos = pos + var_info%ny - ( start_(3) + count_(3) - 1 )
1004  else
1005  pos = pos + start_(3) - 1
1006  end if
1007  pos = pos * var_info%nx * isize + 1
1008  call read_data( fid, pos, ka, var_info%nx, k, start_(2), count_(2), count_(3), var_info%yrev, var(:), ierr )
1009  if ( ierr /= 0 ) then
1010  log_error("FILE_GrADS_read_data",*) 'Failed to read data! ', trim(var_info%name), ', k=',k,', step=',step_, ' in ', trim(gfile)
1011  log_error_cont(*) 'pos=', pos
1012  call prc_abort
1013  end if
1014  end do
1015  if ( var_info%missval .ne. undef ) then
1016  !$omp parallel do &
1017  !$omp private(ii)
1018  do i = 1, nxy
1019  do k = 1, count_(1)
1020  ii = (i-1) * ka + k
1021  if ( abs( var(ii) - var_info%missval ) < eps ) var(ii) = undef
1022  end do
1023  end do
1024  end if
1025  !$omp parallel do &
1026  !$omp private(ii)
1027  do i = 1, nxy
1028  do k = count_(1)+1, ka
1029  ii = (i-1) * ka + k
1030  var(ii) = undef
1031  end do
1032  end do
1033 
1034  end select
1035 
1036  return
1037  end subroutine file_grads_read_data
1038 
1039  subroutine read_data_int1( fid, pos, ka, nx, k, sx, cx, cy, yrev, var, ierr )
1040  integer, intent(in) :: fid, pos
1041  integer, intent(in) :: ka, nx, k, sx, cx, cy
1042  logical, intent(in) :: yrev
1043 
1044  real(RP), intent(out) :: var(:)
1045  integer, intent(out) :: ierr
1046 
1047  integer(1) :: buf(nx,cy)
1048  integer :: i, j
1049 
1050  read(fid, pos=pos, iostat=ierr) buf(:,:)
1051  if ( ierr /= 0 ) return
1052 
1053  if ( yrev ) then
1054  !$omp parallel do
1055  do j = 1, cy
1056  do i = 1, cx
1057  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,cy-j+1)
1058  end do
1059  end do
1060  else
1061  !$omp parallel do
1062  do j = 1, cy
1063  do i = 1, cx
1064  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,j)
1065  end do
1066  end do
1067  end if
1068 
1069  return
1070  end subroutine read_data_int1
1071 
1072  subroutine read_data_int2( fid, pos, ka, nx, k, sx, cx, cy, yrev, var, ierr )
1073  integer, intent(in) :: fid, pos
1074  integer, intent(in) :: ka, nx, k, sx, cx, cy
1075  logical, intent(in) :: yrev
1076 
1077  real(RP), intent(out) :: var(:)
1078  integer, intent(out) :: ierr
1079 
1080  integer(2) :: buf(nx,cy)
1081  integer :: i, j
1082 
1083  read(fid, pos=pos, iostat=ierr) buf(:,:)
1084  if ( ierr /= 0 ) return
1085 
1086  if ( yrev ) then
1087  !$omp parallel do
1088  do j = 1, cy
1089  do i = 1, cx
1090  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,cy-j+1)
1091  end do
1092  end do
1093  else
1094  !$omp parallel do
1095  do j = 1, cy
1096  do i = 1, cx
1097  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,j)
1098  end do
1099  end do
1100  end if
1101 
1102  return
1103  end subroutine read_data_int2
1104 
1105  subroutine read_data_int4( fid, pos, ka, nx, k, sx, cx, cy, yrev, var, ierr )
1106  integer, intent(in) :: fid, pos
1107  integer, intent(in) :: ka, nx, k, sx, cx, cy
1108  logical, intent(in) :: yrev
1109 
1110  real(RP), intent(out) :: var(:)
1111  integer, intent(out) :: ierr
1112 
1113  integer(4) :: buf(nx,cy)
1114  integer :: i, j
1115 
1116  read(fid, pos=pos, iostat=ierr) buf(:,:)
1117  if ( ierr /= 0 ) return
1118 
1119  if ( yrev ) then
1120  !$omp parallel do
1121  do j = 1, cy
1122  do i = 1, cx
1123  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,cy-j+1)
1124  end do
1125  end do
1126  else
1127  !$omp parallel do
1128  do j = 1, cy
1129  do i = 1, cx
1130  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,j)
1131  end do
1132  end do
1133  end if
1134 
1135  return
1136  end subroutine read_data_int4
1137 
1138  subroutine read_data_real4( fid, pos, ka, nx, k, sx, cx, cy, yrev, var, ierr )
1139  integer, intent(in) :: fid, pos
1140  integer, intent(in) :: ka, nx, k, sx, cx, cy
1141  logical, intent(in) :: yrev
1142 
1143  real(RP), intent(out) :: var(:)
1144  integer, intent(out) :: ierr
1145 
1146  real(4) :: buf(nx,cy)
1147  integer :: i, j
1148 
1149  read(fid, pos=pos, iostat=ierr) buf(:,:)
1150  if ( ierr /= 0 ) return
1151 
1152  if ( yrev ) then
1153  !$omp parallel do
1154  do j = 1, cy
1155  do i = 1, cx
1156  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,cy-j+1)
1157  end do
1158  end do
1159  else
1160  !$omp parallel do
1161  do j = 1, cy
1162  do i = 1, cx
1163  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,j)
1164  end do
1165  end do
1166  end if
1167 
1168  return
1169  end subroutine read_data_real4
1170 
1171  subroutine read_data_int8( fid, pos, ka, nx, k, sx, cx, cy, yrev, var, ierr )
1172  integer, intent(in) :: fid, pos
1173  integer, intent(in) :: ka, nx, k, sx, cx, cy
1174  logical, intent(in) :: yrev
1175 
1176  real(RP), intent(out) :: var(:)
1177  integer, intent(out) :: ierr
1178 
1179  integer(8) :: buf(nx,cy)
1180  integer :: i, j
1181 
1182  read(fid, pos=pos, iostat=ierr) buf(:,:)
1183  if ( ierr /= 0 ) return
1184 
1185  if ( yrev ) then
1186  !$omp parallel do
1187  do j = 1, cy
1188  do i = 1, cx
1189  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,cy-j+1)
1190  end do
1191  end do
1192  else
1193  !$omp parallel do
1194  do j = 1, cy
1195  do i = 1, cx
1196  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,j)
1197  end do
1198  end do
1199  end if
1200 
1201  return
1202  end subroutine read_data_int8
1203 
1204  subroutine read_data_real8( fid, pos, ka, nx, k, sx, cx, cy, yrev, var, ierr )
1205  integer, intent(in) :: fid, pos
1206  integer, intent(in) :: ka, nx, k, sx, cx, cy
1207  logical, intent(in) :: yrev
1208 
1209  real(RP), intent(out) :: var(:)
1210  integer, intent(out) :: ierr
1211 
1212  real(8) :: buf(nx,cy)
1213  integer :: i, j
1214 
1215  read(fid, pos=pos, iostat=ierr) buf(:,:)
1216  if ( ierr /= 0 ) return
1217 
1218  if ( yrev ) then
1219  !$omp parallel do
1220  do j = 1, cy
1221  do i = 1, cx
1222  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,cy-j+1)
1223  end do
1224  end do
1225  else
1226  !$omp parallel do
1227  do j = 1, cy
1228  do i = 1, cx
1229  var(k+(i-1)*ka+(j-1)*cx*ka) = buf(sx+i-1,j)
1230  end do
1231  end do
1232  end if
1233 
1234  return
1235  end subroutine read_data_real8
1236 
1237  subroutine check_oldnamelist( fid )
1238  use scale_prc, only: &
1239  prc_abort
1240  implicit none
1241  integer, intent(in) :: fid
1242 
1243  integer :: ierr
1244  logical :: dummy
1245 
1246  namelist /nml_grads_grid/ dummy
1247  namelist /grdvar/ dummy
1248 
1249  read(fid, nml=nml_grads_grid, iostat=ierr)
1250  if( ierr > 0 )then
1251  log_error("check_oldnamelist",*) 'The old namelist "nml_grads_grid" is found.'
1252  log_error_cont(*) 'Use "GrADS_DIMS" instead.'
1253  call prc_abort
1254  endif
1255  rewind(fid)
1256 
1257  read(fid, nml=grdvar, iostat=ierr)
1258  if( ierr > 0 )then
1259  log_error("check_oldnamelist",*) 'The old namelist "grdvar" is found.'
1260  log_error_cont(*) 'Use "GrADS_ITEM" instead.'
1261  call prc_abort
1262  endif
1263  rewind(fid)
1264 
1265  return
1266  end subroutine check_oldnamelist
1267 
1268  ! convert string to upcase
1269  function upcase( str )
1270  character(len=*), intent(in) :: str
1271  character(len=len(str)) :: upcase
1272  integer :: i
1273  do i = 1, len_trim(str)
1274  if ( str(i:i) >= 'a' .and. str(i:i) <= 'z' ) then
1275  upcase(i:i) = char( ichar(str(i:i)) - 32 )
1276  else
1277  upcase(i:i) = str(i:i)
1278  end if
1279  end do
1280  do i = len_trim(str)+1, len(str)
1281  upcase(i:i) = ' '
1282  end do
1283  end function upcase
1284 
1285 end module scale_file_grads
scale_precision::sp
integer, parameter, public sp
Definition: scale_precision.F90:31
scale_prc::prc_abort
subroutine, public prc_abort
Abort Process.
Definition: scale_prc.F90:349
scale_file_grads::file_grads_isoned
logical function, public file_grads_isoned(file_id, var_id)
Definition: scale_file_grads.F90:373
scale_file_grads::file_grads_open
subroutine, public file_grads_open(file_name, file_id)
Open.
Definition: scale_file_grads.F90:104
scale_precision
module PRECISION
Definition: scale_precision.F90:14
scale_file_grads::file_grads_read_1d_id
subroutine file_grads_read_1d_id(file_id, var_id, var, step, start, count, postfix)
Definition: scale_file_grads.F90:506
scale_file_grads::upcase
character(len=len(str)) function upcase(str)
Definition: scale_file_grads.F90:1270
scale_const::const_eps
real(rp), public const_eps
small number
Definition: scale_const.F90:35
scale_file_grads::file_grads_varcheck
subroutine, public file_grads_varcheck(file_id, var_name, exist)
Definition: scale_file_grads.F90:344
scale_file_grads::file_grads_varid
subroutine, public file_grads_varid(file_id, var_name, var_id)
Definition: scale_file_grads.F90:312
scale_io::io_get_available_fid
integer function, public io_get_available_fid()
search & get available file ID
Definition: scale_io.F90:373
scale_file_grads::file_grads_finalize
subroutine, public file_grads_finalize
Definition: scale_file_grads.F90:700
scale_prc
module PROCESS
Definition: scale_prc.F90:11
scale_precision::rp
integer, parameter, public rp
Definition: scale_precision.F90:41
scale_io::io_get_fname
subroutine, public io_get_fname(outstr, instr, rank, ext, len)
generate process specific filename
Definition: scale_io.F90:421
scale_io
module STDIO
Definition: scale_io.F90:10
scale_const
module CONSTANT
Definition: scale_const.F90:11
scale_file_grads::file_grads_read_3d_id
subroutine file_grads_read_3d_id(file_id, var_id, var, step, start, count, postfix)
Definition: scale_file_grads.F90:668
scale_prof
module profiler
Definition: scale_prof.F90:11
scale_file_grads
module file_grads
Definition: scale_file_grads.F90:11
scale_file_grads::file_grads_get_shape_id
subroutine file_grads_get_shape_id(file_id, var_id, shape)
Definition: scale_file_grads.F90:431
scale_file_grads::file_grads_close
subroutine, public file_grads_close(file_id)
Definition: scale_file_grads.F90:713
scale_const::const_undef
real(rp), public const_undef
Definition: scale_const.F90:43
scale_file_grads::file_grads_get_shape_name
subroutine file_grads_get_shape_name(file_id, var_name, shape)
Definition: scale_file_grads.F90:404
scale_file_grads::read_data_int1
subroutine read_data_int1(fid, pos, ka, nx, k, sx, cx, cy, yrev, var, ierr)
Definition: scale_file_grads.F90:1040
scale_file_grads::file_grads_read_2d_id
subroutine file_grads_read_2d_id(file_id, var_id, var, step, start, count, postfix)
Definition: scale_file_grads.F90:588
Generated by   doxygen 1.8.17