-
Notifications
You must be signed in to change notification settings - Fork 6
/
Copy pathfield_routines.F90
175 lines (168 loc) · 6.37 KB
/
field_routines.F90
1
2
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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
!*------------------------------------------------------------------------------
!* Standard Disclaimer
!*
!* Forecast Systems Laboratory
!* NOAA/OAR/ERL/FSL
!* 325 Broadway
!* Boulder, CO 80303
!*
!* AVIATION DIVISION
!* ADVANCED COMPUTING BRANCH
!* SMS/NNT Version: 2.0.0
!*
!* This software and its documentation are in the public domain and
!* are furnished "as is". The United States government, its
!* instrumentalities, officers, employees, and agents make no
!* warranty, express or implied, as to the usefulness of the software
!* and documentation for any purpose. They assume no
!* responsibility (1) for the use of the software and documentation;
!* or (2) to provide technical support to users.
!*
!* Permission to use, copy, modify, and distribute this software is
!* hereby granted, provided that this disclaimer notice appears in
!* all copies. All modifications to this software must be clearly
!* documented, and are solely the responsibility of the agent making
!* the modification. If significant modifications or enhancements
!* are made to this software, the SMS Development team
!* (sms-info@fsl.noaa.gov) should be notified.
!*
!*----------------------------------------------------------------------------
!*
!* WRF NetCDF I/O
! Author: Jacques Middlecoff jacquesm@fsl.noaa.gov
!* Date: October 6, 2000
!*
!*----------------------------------------------------------------------------
subroutine ext_ncd_RealFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
use wrf_data; use module_message
use ext_ncd_support_routines
implicit none
include 'wrf_status_codes.h'
include 'netcdf.inc'
character (*) ,intent(in) :: IO
integer ,intent(in) :: NCID
integer ,intent(in) :: VarID
integer ,dimension(NVarDims),intent(in) :: VStart
integer ,dimension(NVarDims),intent(in) :: VCount
real, dimension(*) ,intent(inout) :: Data
integer ,intent(out) :: Status
integer :: stat
if(IO == 'write') then
stat = NF_PUT_VARA_REAL(NCID,VarID,VStart,VCount,Data)
else
stat = NF_GET_VARA_REAL(NCID,VarID,VStart,VCount,Data)
endif
call netcdf_err(stat,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
call mdl_message ( msg)
endif
return
end subroutine ext_ncd_RealFieldIO
subroutine ext_ncd_DoubleFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
use wrf_data; use module_message
use ext_ncd_support_routines
implicit none
include 'wrf_status_codes.h'
include 'netcdf.inc'
character (*) ,intent(in) :: IO
integer ,intent(in) :: NCID
integer ,intent(in) :: VarID
integer ,dimension(NVarDims),intent(in) :: VStart
integer ,dimension(NVarDims),intent(in) :: VCount
real*8 ,intent(inout) :: Data
integer ,intent(out) :: Status
integer :: stat
if(IO == 'write') then
stat = NF_PUT_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data)
else
stat = NF_GET_VARA_DOUBLE(NCID,VarID,VStart,VCount,Data)
endif
call netcdf_err(stat,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
call mdl_message ( msg)
endif
return
end subroutine ext_ncd_DoubleFieldIO
subroutine ext_ncd_IntFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
use wrf_data; use module_message
use ext_ncd_support_routines
implicit none
include 'wrf_status_codes.h'
include 'netcdf.inc'
character (*) ,intent(in) :: IO
integer ,intent(in) :: NCID
integer ,intent(in) :: VarID
integer ,dimension(NVarDims),intent(in) :: VStart
integer ,dimension(NVarDims),intent(in) :: VCount
integer ,intent(inout) :: Data
integer ,intent(out) :: Status
integer :: stat
if(IO == 'write') then
stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Data)
else
stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Data)
endif
call netcdf_err(stat,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
call mdl_message ( msg)
endif
return
end subroutine ext_ncd_IntFieldIO
subroutine ext_ncd_LogicalFieldIO(IO,NCID,VarID,VStart,VCount,Data,Status)
use wrf_data; use module_message
use ext_ncd_support_routines
implicit none
include 'wrf_status_codes.h'
include 'netcdf.inc'
character (*) ,intent(in) :: IO
integer ,intent(in) :: NCID
integer ,intent(in) :: VarID
integer,dimension(NVarDims) ,intent(in) :: VStart
integer,dimension(NVarDims) ,intent(in) :: VCount
logical,dimension(VCount(1),VCount(2),VCount(3)),intent(inout) :: Data
integer ,intent(out) :: Status
integer,dimension(:,:,:),allocatable :: Buffer
integer :: stat
integer :: i,j,k
allocate(Buffer(VCount(1),VCount(2),VCount(3)), STAT=stat)
if(stat/= 0) then
Status = WRF_ERR_FATAL_ALLOCATION_ERROR
write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
call mdl_message ( msg)
return
endif
if(IO == 'write') then
do k=1,VCount(3)
do j=1,VCount(2)
do i=1,VCount(1)
if(data(i,j,k)) then
Buffer(i,j,k)=1
else
Buffer(i,j,k)=0
endif
enddo
enddo
enddo
stat = NF_PUT_VARA_INT(NCID,VarID,VStart,VCount,Buffer)
else
stat = NF_GET_VARA_INT(NCID,VarID,VStart,VCount,Buffer)
Data = Buffer == 1
endif
call netcdf_err(stat,Status)
if(Status /= WRF_NO_ERR) then
write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
call mdl_message ( msg)
return
endif
deallocate(Buffer, STAT=stat)
if(stat/= 0) then
Status = WRF_ERR_FATAL_DEALLOCATION_ERR
write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
call mdl_message ( msg)
return
endif
return
end subroutine ext_ncd_LogicalFieldIO