1 |
C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_readvector.F,v 1.15 2009/09/01 19:00:15 jmc Exp $ |
2 |
C $Name: $ |
3 |
|
4 |
#include "MDSIO_OPTIONS.h" |
5 |
|
6 |
CBOP |
7 |
C !ROUTINE: MDS_READ_TAPE |
8 |
C !INTERFACE: |
9 |
SUBROUTINE MDS_READ_TAPE( |
10 |
I fName, |
11 |
I filePrec, |
12 |
I arrType, |
13 |
I nSize, |
14 |
O fldR8, fldR4, |
15 |
I singleCpuIO, |
16 |
I iRec, |
17 |
I myThid ) |
18 |
|
19 |
C !DESCRIPTION: |
20 |
C MDS_READ_TAPE: load an array (treated as vector) for a tape-file |
21 |
C (renamed from MDSREADVECTOR with 2 explicit output array typest) |
22 |
C |
23 |
C Arguments: |
24 |
C fName string :: base name for file to read |
25 |
C filePrec integer :: number of bits per word in file (32 or 64) |
26 |
C arrType char(2) :: which array (fldR8/R4) to read, either "R8" or "R4" |
27 |
C nSize integer :: number of elements of input array "fldR8/R4" to read |
28 |
C fldR8 ( R8 ) :: array to read if arrType="R8", fldR8(nSize) |
29 |
C fldR4 ( R4 ) :: array to read if arrType="R4", fldR4(nSize) |
30 |
C singleCpuIO ( L ) :: only proc 0 do IO and send data to other procs |
31 |
C iRec integer :: record number to read |
32 |
C myThid integer :: my Thread Id number |
33 |
|
34 |
C !USES: |
35 |
IMPLICIT NONE |
36 |
|
37 |
C-- Global variables -- |
38 |
#include "SIZE.h" |
39 |
#include "EEPARAMS.h" |
40 |
#include "PARAMS.h" |
41 |
|
42 |
C !INPUT/OUTPUT PARAMETERS: |
43 |
CHARACTER*(*) fName |
44 |
INTEGER filePrec |
45 |
CHARACTER*(2) arrType |
46 |
INTEGER nSize |
47 |
_R8 fldR8(*) |
48 |
_R4 fldR4(*) |
49 |
LOGICAL singleCpuIO |
50 |
INTEGER iRec |
51 |
INTEGER myThid |
52 |
|
53 |
#ifdef ALLOW_AUTODIFF |
54 |
|
55 |
C !FUNCTIONS: |
56 |
INTEGER ILNBLNK |
57 |
INTEGER MDS_RECLEN |
58 |
EXTERNAL ILNBLNK |
59 |
EXTERNAL MDS_RECLEN |
60 |
|
61 |
C !LOCAL VARIABLES: |
62 |
CHARACTER*(MAX_LEN_FNAM) dataFName, pfName |
63 |
INTEGER iG, jG, jRec, dUnit, IL, pIL |
64 |
LOGICAL exst |
65 |
LOGICAL globalFile, fileIsOpen |
66 |
INTEGER length_of_rec |
67 |
CHARACTER*(MAX_LEN_MBUF) msgBuf |
68 |
|
69 |
C simple implementation of singleCpuIO without any specific EXCH2 |
70 |
C feature (should work as long as reading and writing match) |
71 |
INTEGER j |
72 |
INTEGER vec_size |
73 |
C Note: would be better to use explicit (allocate/delocate) dynamical |
74 |
C allocation instead of this implicit form: |
75 |
_R8 gl_buffer_r8(nSize*nPx*nPy) |
76 |
_R4 gl_buffer_r4(nSize*nPx*nPy) |
77 |
_R8 local_r8 (nSize) |
78 |
_R4 local_r4 (nSize) |
79 |
CEOP |
80 |
|
81 |
vec_size = nSize*nPx*nPy |
82 |
|
83 |
C-- Only do I/O if I am the master thread |
84 |
_BEGIN_MASTER( myThid ) |
85 |
|
86 |
C- Record number must be >= 1 |
87 |
IF ( iRec.LT.1 ) THEN |
88 |
WRITE(msgBuf,'(A,I10)') |
89 |
& ' MDS_READ_TAPE: argument iRec =',iRec |
90 |
CALL PRINT_ERROR( msgBuf, myThid ) |
91 |
WRITE(msgBuf,'(A)') |
92 |
& ' MDS_READ_TAPE: invalid value for iRec' |
93 |
CALL PRINT_ERROR( msgBuf, myThid ) |
94 |
STOP 'ABNORMAL END: S/R MDS_READ_TAPE' |
95 |
ENDIF |
96 |
|
97 |
C- Assume nothing |
98 |
globalFile = .FALSE. |
99 |
fileIsOpen = .FALSE. |
100 |
IL = ILNBLNK( fName ) |
101 |
pIL = ILNBLNK( mdsioLocalDir ) |
102 |
|
103 |
C- Assign special directory |
104 |
IF ( mdsioLocalDir .NE. ' ' ) THEN |
105 |
WRITE(pfName,'(2A)') mdsioLocalDir(1:pIL), fName(1:IL) |
106 |
ELSE |
107 |
pfName = fName |
108 |
ENDIF |
109 |
pIL = ILNBLNK( pfName ) |
110 |
|
111 |
C- Assign a free unit number as the I/O channel for this routine |
112 |
CALL MDSFINDUNIT( dUnit, myThid ) |
113 |
|
114 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
115 |
IF ( singleCpuIO ) THEN |
116 |
|
117 |
IF ( myProcId .EQ. 0 ) THEN |
118 |
C-- Master thread of process 0, only, opens a global file |
119 |
|
120 |
C- Check first for global file with with MDS name (ie. fName.data) |
121 |
WRITE(dataFName,'(2A)') fName(1:IL),'.data' |
122 |
INQUIRE( file=dataFName, exist=exst ) |
123 |
IF (exst) globalFile = .TRUE. |
124 |
|
125 |
C- If global file is visible to process 0, then open it here. |
126 |
IF ( globalFile ) THEN |
127 |
IF ( debugLevel .GE. debLevB ) THEN |
128 |
WRITE(msgBuf,'(A,A)') |
129 |
& ' MDS_READ_TAPE: opening global file: ',dataFName(1:IL+5) |
130 |
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, |
131 |
& SQUEEZE_RIGHT, myThid ) |
132 |
ENDIF |
133 |
length_of_rec = MDS_RECLEN( filePrec, vec_size, myThid ) |
134 |
OPEN( dUnit, file=dataFName, status='old', |
135 |
& access='direct', recl=length_of_rec ) |
136 |
ELSE |
137 |
C Otherwise stop program. |
138 |
WRITE(msgBuf,'(2A)') |
139 |
& ' MDS_READ_TAPE: filename: ',dataFName(1:IL) |
140 |
C-jmc: why double print (stdout + stderr) ? |
141 |
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, |
142 |
& SQUEEZE_RIGHT, myThid ) |
143 |
CALL PRINT_ERROR( msgBuf, myThid ) |
144 |
WRITE(msgBuf,'(A)') |
145 |
& ' MDS_READ_TAPE: File does not exist' |
146 |
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, |
147 |
& SQUEEZE_RIGHT, myThid ) |
148 |
CALL PRINT_ERROR( msgBuf, myThid ) |
149 |
STOP 'ABNORMAL END: S/R MDS_READ_TAPE' |
150 |
ENDIF |
151 |
|
152 |
C- Read into global buffer: |
153 |
IF ( filePrec.EQ.precFloat32 ) THEN |
154 |
READ(dUnit,rec=iRec) gl_buffer_r4 |
155 |
#ifdef _BYTESWAPIO |
156 |
CALL MDS_BYTESWAPR4( vec_size, gl_buffer_r4 ) |
157 |
#endif |
158 |
ELSEIF ( filePrec.EQ.precFloat64 ) THEN |
159 |
READ(dUnit,rec=iRec) gl_buffer_r8 |
160 |
#ifdef _BYTESWAPIO |
161 |
CALL MDS_BYTESWAPR8( vec_size, gl_buffer_r8 ) |
162 |
#endif |
163 |
ENDIF |
164 |
|
165 |
C- Close data-file |
166 |
CLOSE( dUnit ) |
167 |
|
168 |
C-- end if myProcId=0 |
169 |
ENDIF |
170 |
|
171 |
IF ( filePrec.EQ.precFloat32 ) THEN |
172 |
CALL SCATTER_VEC_R4( gl_buffer_r4, local_r4, nSize, myThid ) |
173 |
ELSEIF ( filePrec.EQ.precFloat64 ) THEN |
174 |
CALL SCATTER_VEC_R8( gl_buffer_r8, local_r8, nSize, myThid ) |
175 |
ELSE |
176 |
WRITE(msgBuf,'(A)') |
177 |
& ' MDS_READ_TAPE: illegal value for filePrec' |
178 |
CALL PRINT_ERROR( msgBuf, myThid ) |
179 |
STOP 'ABNORMAL END: S/R MDS_READ_TAPE' |
180 |
ENDIF |
181 |
|
182 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
183 |
C if ( singleCpuIO ), else |
184 |
ELSEIF ( .NOT. singleCpuIO ) THEN |
185 |
|
186 |
C- Check first for global file with with MDS name (ie. fName.data) |
187 |
WRITE(dataFName,'(2A)') fName(1:IL),'.data' |
188 |
INQUIRE( file=dataFName, exist=exst ) |
189 |
IF (exst) THEN |
190 |
IF ( debugLevel .GE. debLevB ) THEN |
191 |
WRITE(msgBuf,'(A,A)') |
192 |
& ' MDS_READ_TAPE: opening global file: ',dataFName(1:IL+5) |
193 |
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, |
194 |
& SQUEEZE_RIGHT, myThid ) |
195 |
ENDIF |
196 |
globalFile = .TRUE. |
197 |
C- And open it here |
198 |
length_of_rec = MDS_RECLEN( filePrec, nSize, myThid ) |
199 |
OPEN( dUnit, file=dataFName, status='old', |
200 |
& access='direct', recl=length_of_rec ) |
201 |
fileIsOpen=.TRUE. |
202 |
ENDIF |
203 |
|
204 |
C- If we are reading from a tiled MDS file then we open each one here |
205 |
IF ( .NOT.globalFile ) THEN |
206 |
iG = 1 + (myXGlobalLo-1)/sNx |
207 |
jG = 1 + (myYGlobalLo-1)/sNy |
208 |
WRITE(dataFName,'(2A,I3.3,A,I3.3,A)') |
209 |
& pfName(1:pIL),'.',iG,'.',jG,'.data' |
210 |
INQUIRE( file=dataFName, exist=exst ) |
211 |
IF (exst) THEN |
212 |
IF ( debugLevel .GE. debLevB ) THEN |
213 |
WRITE(msgBuf,'(A,A)') |
214 |
& ' MDS_READ_TAPE: opening file: ',dataFName(1:pIL+13) |
215 |
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, |
216 |
& SQUEEZE_RIGHT, myThid ) |
217 |
ENDIF |
218 |
length_of_rec = MDS_RECLEN( filePrec, nSize, myThid ) |
219 |
OPEN( dUnit, file=dataFName, status='old', |
220 |
& access='direct', recl=length_of_rec ) |
221 |
fileIsOpen=.TRUE. |
222 |
ELSE |
223 |
fileIsOpen=.FALSE. |
224 |
WRITE(msgBuf,'(4A)') |
225 |
& ' MDS_READ_TAPE: missing file: ',fName(1:IL), |
226 |
& ' , ',dataFName(1:pIL+13) |
227 |
CALL PRINT_ERROR( msgBuf, myThid ) |
228 |
STOP 'ABNORMAL END: S/R MDS_READ_TAPE' |
229 |
ENDIF |
230 |
ENDIF |
231 |
|
232 |
IF ( fileIsOpen ) THEN |
233 |
IF ( globalFile ) THEN |
234 |
C- read the same way it was written: |
235 |
jRec = 1 + myProcId + (iRec-1)*nPx*nPy |
236 |
ELSE |
237 |
jRec = iRec |
238 |
ENDIF |
239 |
IF ( filePrec.EQ.precFloat32 ) THEN |
240 |
READ(dUnit,rec=jRec) local_r4 |
241 |
#ifdef _BYTESWAPIO |
242 |
CALL MDS_BYTESWAPR4( nSize, local_r4 ) |
243 |
#endif |
244 |
ELSEIF ( filePrec.EQ.precFloat64 ) THEN |
245 |
READ(dUnit,rec=jRec) local_r8 |
246 |
#ifdef _BYTESWAPIO |
247 |
CALL MDS_BYTESWAPR8( nSize, local_r8 ) |
248 |
#endif |
249 |
ELSE |
250 |
WRITE(msgBuf,'(A)') |
251 |
& ' MDS_READ_TAPE: illegal value for filePrec' |
252 |
CALL PRINT_ERROR( msgBuf, myThid ) |
253 |
STOP 'ABNORMAL END: S/R MDS_READ_TAPE' |
254 |
ENDIF |
255 |
C-- If file was opened then close it |
256 |
CLOSE( dUnit ) |
257 |
fileIsOpen = .FALSE. |
258 |
ENDIF |
259 |
|
260 |
C end-if ( .not. singleCpuIO ) |
261 |
ENDIF |
262 |
|
263 |
_END_MASTER( myThid ) |
264 |
|
265 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
266 |
|
267 |
C-- Copy local buffer into output array |
268 |
IF ( arrType.EQ.'R4' ) THEN |
269 |
IF ( filePrec.EQ.precFloat32 ) THEN |
270 |
DO j=1,nSize |
271 |
fldR4(j) = local_r4(j) |
272 |
ENDDO |
273 |
ELSE |
274 |
DO j=1,nSize |
275 |
fldR4(j) = local_r8(j) |
276 |
ENDDO |
277 |
ENDIF |
278 |
ELSEIF ( arrType.EQ.'R8' ) THEN |
279 |
IF ( filePrec.EQ.precFloat32 ) THEN |
280 |
DO j=1,nSize |
281 |
fldR8(j) = local_r4(j) |
282 |
ENDDO |
283 |
ELSE |
284 |
DO j=1,nSize |
285 |
fldR8(j) = local_r8(j) |
286 |
ENDDO |
287 |
ENDIF |
288 |
ELSE |
289 |
WRITE(msgBuf,'(A)') |
290 |
& ' MDS_READ_TAPE: illegal value for arrType' |
291 |
CALL PRINT_ERROR( msgBuf, myThid ) |
292 |
STOP 'ABNORMAL END: S/R MDS_READ_TAPE' |
293 |
ENDIF |
294 |
|
295 |
#else /* ALLOW_AUTODIFF */ |
296 |
STOP 'ABNORMAL END: S/R MDS_READ_TAPE is empty' |
297 |
#endif /* ALLOW_AUTODIFF */ |
298 |
|
299 |
RETURN |
300 |
END |