source: trunk/WRF.COMMON/WRFV3/external/io_netcdf/field_routines.F90 @ 2759

Last change on this file since 2759 was 2759, checked in by aslmd, 2 years ago

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 6.3 KB
RevLine 
[2759]1!*------------------------------------------------------------------------------
2!*  Standard Disclaimer
3!*
4!*  Forecast Systems Laboratory
5!*  NOAA/OAR/ERL/FSL
6!*  325 Broadway
7!*  Boulder, CO     80303
8!*
9!*  AVIATION DIVISION
10!*  ADVANCED COMPUTING BRANCH
11!*  SMS/NNT Version: 2.0.0
12!*
13!*  This software and its documentation are in the public domain and
14!*  are furnished "as is".  The United States government, its
15!*  instrumentalities, officers, employees, and agents make no
16!*  warranty, express or implied, as to the usefulness of the software
17!*  and documentation for any purpose.  They assume no
18!*  responsibility (1) for the use of the software and documentation;
19!*  or (2) to provide technical support to users.
20!*
21!*  Permission to use, copy, modify, and distribute this software is
22!*  hereby granted, provided that this disclaimer notice appears in
23!*  all copies.  All modifications to this software must be clearly
24!*  documented, and are solely the responsibility of the agent making
25!*  the modification.  If significant modifications or enhancements
26!*  are made to this software, the SMS Development team
27!*  (sms-info@fsl.noaa.gov) should be notified.
28!*
29!*----------------------------------------------------------------------------
30!*
31!*  WRF NetCDF I/O
32!   Author:  Jacques Middlecoff jacquesm@fsl.noaa.gov
33!*  Date:    October 6, 2000
34!*
35!*----------------------------------------------------------------------------
36subroutine ext_ncd_RealFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
37  use wrf_data
38  use ext_ncd_support_routines
39  implicit none
40  include 'wrf_status_codes.h'
41  include 'netcdf.inc'
42  character (*)               ,intent(in)    :: IO
43  integer                     ,intent(in)    :: NCID
44  integer                     ,intent(in)    :: VarID
45  integer ,dimension(NVarDims),intent(in)    :: VStart
46  integer ,dimension(NVarDims),intent(in)    :: VCount
47  real, dimension(*)          ,intent(inout) :: Data
48  integer                     ,intent(out)   :: Status
49  integer                                    :: stat
50
51  if(IO == 'write') then
52    stat = NF_PUT_VARA_REAL(NCID,VarID,VStart,VCount,Data)
53  else
54    stat = NF_GET_VARA_REAL(NCID,VarID,VStart,VCount,Data)
55  endif
56  call netcdf_err(stat,Status)
57  if(Status /= WRF_NO_ERR) then
58    write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
59    call wrf_debug ( WARN , msg)
60  endif
61  return
62end subroutine ext_ncd_RealFieldIO
63
64subroutine ext_ncd_DoubleFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
65  use wrf_data
66  use ext_ncd_support_routines
67  implicit none
68  include 'wrf_status_codes.h'
69  include 'netcdf.inc'
70  character (*)               ,intent(in)    :: IO
71  integer                     ,intent(in)    :: NCID
72  integer                     ,intent(in)    :: VarID
73  integer ,dimension(NVarDims),intent(in)    :: VStart
74  integer ,dimension(NVarDims),intent(in)    :: VCount
75  real*8                      ,intent(inout) :: Data
76  integer                     ,intent(out)   :: Status
77  integer                                    :: stat
78
79  if(IO == 'write') then
80    stat = NF_PUT_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data)
81  else
82    stat = NF_GET_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data)
83  endif
84  call netcdf_err(stat,Status)
85  if(Status /= WRF_NO_ERR) then
86    write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
87    call wrf_debug ( WARN , msg)
88  endif
89  return
90end subroutine ext_ncd_DoubleFieldIO
91
92subroutine ext_ncd_IntFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
93  use wrf_data
94  use ext_ncd_support_routines
95  implicit none
96  include 'wrf_status_codes.h'
97  include 'netcdf.inc'
98  character (*)               ,intent(in)    :: IO
99  integer                     ,intent(in)    :: NCID
100  integer                     ,intent(in)    :: VarID
101  integer ,dimension(NVarDims),intent(in)    :: VStart
102  integer ,dimension(NVarDims),intent(in)    :: VCount
103  integer                     ,intent(inout) :: Data
104  integer                     ,intent(out)   :: Status
105  integer                                    :: stat
106
107  if(IO == 'write') then
108    stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Data)
109  else
110    stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Data)
111  endif
112  call netcdf_err(stat,Status)
113  if(Status /= WRF_NO_ERR) then
114    write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
115    call wrf_debug ( WARN , msg)
116  endif
117  return
118end subroutine ext_ncd_IntFieldIO
119
120subroutine ext_ncd_LogicalFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
121  use wrf_data
122  use ext_ncd_support_routines
123  implicit none
124  include 'wrf_status_codes.h'
125  include 'netcdf.inc'
126  character (*)                                   ,intent(in)    :: IO
127  integer                                         ,intent(in)    :: NCID
128  integer                                         ,intent(in)    :: VarID
129  integer,dimension(NVarDims)                     ,intent(in)    :: VStart
130  integer,dimension(NVarDims)                     ,intent(in)    :: VCount
131  logical,dimension(VCount(1),VCount(2),VCount(3)),intent(inout) :: Data
132  integer                                         ,intent(out)   :: Status
133  integer,dimension(:,:,:),allocatable                           :: Buffer
134  integer                                                        :: stat
135  integer                                                        :: i,j,k
136
137  allocate(Buffer(VCount(1),VCount(2),VCount(3)), STAT=stat)
138  if(stat/= 0) then
139    Status = WRF_ERR_FATAL_ALLOCATION_ERROR
140    write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
141    call wrf_debug ( FATAL , msg)
142    return
143  endif
144  if(IO == 'write') then
145    do k=1,VCount(3)
146      do j=1,VCount(2)
147        do i=1,VCount(1)
148          if(data(i,j,k)) then
149            Buffer(i,j,k)=1
150          else
151            Buffer(i,j,k)=0
152          endif
153        enddo
154      enddo
155    enddo
156    stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Buffer)
157  else
158    stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Buffer)
159    Data = Buffer == 1
160  endif
161  call netcdf_err(stat,Status)
162  if(Status /= WRF_NO_ERR) then
163    write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
164    call wrf_debug ( WARN , msg)
165    return
166  endif
167  deallocate(Buffer, STAT=stat)
168  if(stat/= 0) then
169    Status = WRF_ERR_FATAL_DEALLOCATION_ERR
170    write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
171    call wrf_debug ( FATAL , msg)
172    return
173  endif
174  return
175end subroutine ext_ncd_LogicalFieldIO
Note: See TracBrowser for help on using the repository browser.