source: trunk/WRF.COMMON/WRFV3/external/io_pnetcdf/ext_pnc_get_var_ti.code

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

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size

File size: 6.0 KB
Line 
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!*----------------------------------------------------------------------------
36
37  use wrf_data_pnc
38  use ext_pnc_support_routines
39  implicit none
40  include 'wrf_status_codes.h'
41#  include "pnetcdf.inc"
42  integer               ,intent(in)     :: DataHandle
43  character*(*)         ,intent(in)     :: Element
44  character*(*)         ,intent(in)     :: Var
45  TYPE_DATA
46  TYPE_COUNT
47  TYPE_OUTCOUNT
48  integer               ,intent(out)    :: Status
49  type(wrf_data_handle) ,pointer        :: DH
50  integer                               :: XLen
51  integer(KIND=MPI_OFFSET_KIND)         :: XLen_offset
52  TYPE_BUFFER
53  character (VarNameLen)                :: VarName
54  integer                               :: stat
55  integer                               :: NVar
56  integer                               :: XType
57
58  if(Count <= 0) then
59    Status = WRF_WARN_ZERO_LENGTH_GET 
60    write(msg,*) &
61'Warning ZERO LENGTH GET in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
62    call wrf_debug ( WARN , msg)
63    return
64  endif
65  VarName = Var
66  call GetDH(DataHandle,DH,Status)
67  if(Status /= WRF_NO_ERR) then
68    write(msg,*) &
69'Warning Status = ',Status,' in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
70    call wrf_debug ( WARN , msg)
71    return
72  endif
73  if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
74    Status = WRF_WARN_FILE_NOT_OPENED 
75    write(msg,*) &
76'Warning FILE NOT OPENED in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
77    call wrf_debug ( WARN , msg)
78  elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
79    Status = WRF_WARN_DRYRUN_READ 
80    write(msg,*) &
81'Warning DRYRUN READ in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
82    call wrf_debug ( WARN , msg)
83  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
84    Status = WRF_WARN_READ_WONLY_FILE
85    write(msg,*) &
86'Warning READ WONLY FILE in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
87    call wrf_debug ( WARN , msg)
88  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
89    do NVar=1,DH%NumVars
90      if(DH%VarNames(NVar) == VarName) then
91        exit
92      elseif(NVar == DH%NumVars) then
93        Status = WRF_WARN_VAR_NF 
94        write(msg,*) &
95'Warning VARIABLE NOT FOUND in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
96        call wrf_debug ( WARN , msg)
97        return
98      endif
99    enddo
100    XLen_offset = i2offset(XLen)
101    stat = NFMPI_INQ_ATT(DH%NCID,DH%VarIDs(NVar),trim(Element),XType,XLen_offset)
102    XLen = XLen_offset
103    call netcdf_err(stat,Status)
104    if(Status /= WRF_NO_ERR) then
105      write(msg,*) &
106'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
107      call wrf_debug ( WARN , msg)
108    endif
109    if ( NF_TYPE == NF_DOUBLE .OR. NF_TYPE == NF_FLOAT ) then
110      if( .NOT. ( XType==NF_FLOAT .OR. XType==NF_DOUBLE) ) then
111        Status = WRF_WARN_TYPE_MISMATCH 
112        write(msg,*) &
113'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
114        call wrf_debug ( WARN , msg)
115        return
116      endif
117    else
118      if(XType /= NF_TYPE) then
119        Status = WRF_WARN_TYPE_MISMATCH 
120        write(msg,*) &
121'Warning TYPE MISMATCH in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
122        call wrf_debug ( WARN , msg)
123        return
124      endif
125    endif
126#ifndef CHAR_TYPE
127    allocate(Buffer(XLen), STAT=stat)
128    if(stat/= 0) then
129      Status = WRF_ERR_FATAL_ALLOCATION_ERROR
130      write(msg,*) &
131'Fatal ALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
132      call wrf_debug ( FATAL , msg)
133      return
134    endif
135    stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Buffer )
136#else
137    if(XLen > len(Data)) then
138      Status = WRF_WARN_CHARSTR_GT_LENDATA   
139      write(msg,*) &
140'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
141      call wrf_debug ( WARN , msg)
142      return
143    endif
144    stat = NF_ROUTINE(DH%NCID,DH%VarIDs(NVar),trim(Element), Data )
145#endif
146    call netcdf_err(stat,Status)
147    if(Status /= WRF_NO_ERR) then
148      write(msg,*) &
149'NetCDF error in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__,' Element ',Element
150      call wrf_debug ( WARN , msg)
151    endif
152    COPY
153#ifndef CHAR_TYPE
154    deallocate(Buffer, STAT=stat)
155    if(stat/= 0) then
156      Status = WRF_ERR_FATAL_DEALLOCATION_ERR 
157      write(msg,*) &
158'Fatal DEALLOCATION ERROR in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
159      call wrf_debug ( FATAL , msg)
160      return
161    endif
162    if(XLen > Count) then
163      OutCount = Count
164      Status   = WRF_WARN_MORE_DATA_IN_FILE 
165    else
166      OutCount = XLen
167      Status   = WRF_NO_ERR
168    endif
169#endif
170  else
171    Status = WRF_ERR_FATAL_BAD_FILE_STATUS 
172    write(msg,*) &
173'Fatal error BAD FILE STATUS in ',__FILE__,' ',ROUTINE_TYPE,', line', __LINE__
174    call wrf_debug ( FATAL , msg)
175    return
176  endif
177  return
Note: See TracBrowser for help on using the repository browser.