/[MITgcm]/MITgcm/pkg/mdsio/mdsio_read_field.F
ViewVC logotype

Contents of /MITgcm/pkg/mdsio/mdsio_read_field.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.5 - (show annotations) (download)
Wed May 6 02:42:49 2009 UTC (15 years, 1 month ago) by jmc
Branch: MAIN
Changes since 1.4: +27 -83 lines
new S/R to map global io-buffer to global model array ; used by both
 mdsio_write_field.F and mdsio_read_field.F (useSingleCpuIO).

1 C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_read_field.F,v 1.4 2008/12/30 00:13:35 jahn Exp $
2 C $Name: $
3
4 #include "MDSIO_OPTIONS.h"
5
6 CBOP
7 C !ROUTINE: MDS_READ_FIELD
8 C !INTERFACE:
9 SUBROUTINE MDS_READ_FIELD(
10 I fName,
11 I filePrec,
12 I useCurrentDir,
13 I arrType,
14 I kSize,kLo,kHi,
15 O arr,
16 I irecord,
17 I myThid )
18
19 C !DESCRIPTION:
20 C Arguments:
21 C
22 C fName (string) :: base name for file to read
23 C filePrec (integer) :: number of bits per word in file (32 or 64)
24 C useCurrentDir(logic):: always read from the current directory (even if
25 C "mdsioLocalDir" is set)
26 C arrType (char(2)) :: declaration of "arr": either "RS" or "RL"
27 C kSize (integer) :: size of third dimension: normally either 1 or Nr
28 C kLo (integer) :: 1rst vertical level (of array "arr") to read-in
29 C kHi (integer) :: last vertical level (of array "arr") to read-in
30 C arr ( RS/RL ) :: array to read into, arr(:,:,kSize,:,:)
31 C irecord (integer) :: record number to read
32 C myIter (integer) :: time step number
33 C myThid (integer) :: thread identifier
34 C
35 C MDS_READ_FIELD first checks to see IF the file "fName" exists, then
36 C IF the file "fName.data" exists and finally the tiled files of the
37 C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
38 C read because it is difficult to parse files in fortran.
39 C The precision of the file is decsribed by filePrec, set either
40 C to floatPrec32 or floatPrec64. The precision or declaration of
41 C the array argument must be consistently described by the char*(2)
42 C string arrType, either "RS" or "RL".
43 C (kSize,kLo,kHi) allows for both 2-D and 3-D arrays to be handled, with
44 C the option to only read and fill-in a sub-set of consecutive vertical
45 C levels (from kLo to kHi) ; (kSize,kLo,kHi)=(1,1,1) implies a 2-D model
46 C field and (kSize,kLo,kHi)=(Nr,1,Nr) implies a 3-D model field.
47 C irecord is the record number to be read and must be >= 1.
48 C The file data is stored in arr *but* the overlaps are *not* updated,
49 C i.e., an exchange must be called. This is because the routine is
50 C sometimes called from within a MASTER_THID region.
51 C
52 C Created: 03/16/99 adcroft@mit.edu
53 CEOP
54
55 C !USES:
56 IMPLICIT NONE
57 C Global variables / common blocks
58 #include "SIZE.h"
59 #include "EEPARAMS.h"
60 #include "PARAMS.h"
61 #ifdef ALLOW_EXCH2
62 #include "W2_EXCH2_TOPOLOGY.h"
63 #include "W2_EXCH2_PARAMS.h"
64 #endif /* ALLOW_EXCH2 */
65 #include "MDSIO_SCPU.h"
66
67 C !INPUT PARAMETERS:
68 CHARACTER*(*) fName
69 INTEGER filePrec
70 LOGICAL useCurrentDir
71 CHARACTER*(2) arrType
72 INTEGER kSize, kLo, kHi
73 INTEGER irecord
74 INTEGER myThid
75 C !OUTPUT PARAMETERS:
76 Real arr(*)
77
78 C !FUNCTIONS
79 INTEGER ILNBLNK
80 INTEGER MDS_RECLEN
81 LOGICAL MASTER_CPU_IO
82 EXTERNAL ILNBLNK
83 EXTERNAL MDS_RECLEN
84 EXTERNAL MASTER_CPU_IO
85
86 C !LOCAL VARIABLES:
87 CHARACTER*(MAX_LEN_FNAM) dataFName,pfName
88 CHARACTER*(MAX_LEN_MBUF) msgBuf
89 LOGICAL exst
90 LOGICAL globalFile, fileIsOpen
91 LOGICAL iAmDoingIO
92 INTEGER xSize, ySize
93 INTEGER iG,jG,bi,bj,i,j,k,nNz
94 INTEGER irec,dUnit,IL,pIL
95 INTEGER length_of_rec
96 Real*4 r4seg(sNx)
97 Real*8 r8seg(sNx)
98 #ifdef ALLOW_EXCH2
99 INTEGER iGjLoc, jGjLoc
100 c INTEGER tGy,tGx,tNy,tNx,tN
101 INTEGER tGy,tGx, tNx,tN
102 INTEGER global_nTx
103 #endif /* ALLOW_EXCH2 */
104 INTEGER tNy
105
106 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
107 C Set dimensions:
108 xSize = Nx
109 ySize = Ny
110 #if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)
111 xSize = exch2_global_Nx
112 ySize = exch2_global_Ny
113 #endif
114
115 C Assume nothing
116 globalFile = .FALSE.
117 fileIsOpen = .FALSE.
118 IL = ILNBLNK( fName )
119 pIL = ILNBLNK( mdsioLocalDir )
120 nNz = 1 + kHi - kLo
121
122 C Only do I/O if I am the master thread (and mpi process 0 IF useSingleCpuIO):
123 iAmDoingIO = MASTER_CPU_IO(myThid)
124
125 C Only do I/O if I am the master thread
126 IF ( iAmDoingIO ) THEN
127
128 C Record number must be >= 1
129 IF (irecord .LT. 1) THEN
130 WRITE(msgBuf,'(A,I9.8)')
131 & ' MDS_READ_FIELD: argument irecord = ',irecord
132 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
133 & SQUEEZE_RIGHT , myThid)
134 WRITE(msgBuf,'(A)')
135 & ' MDS_READ_FIELD: Invalid value for irecord'
136 CALL PRINT_ERROR( msgBuf, myThid )
137 STOP 'ABNORMAL END: S/R MDS_READ_FIELD'
138 ENDIF
139 C check for valid sub-set of levels:
140 IF ( kLo.LT.1 .OR. kHi.GT.kSize ) THEN
141 WRITE(msgBuf,'(3(A,I6))')
142 & ' MDS_READ_FIELD: arguments kSize=', kSize,
143 & ' , kLo=', kLo, ' , kHi=', kHi
144 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
145 & SQUEEZE_RIGHT , myThid)
146 WRITE(msgBuf,'(A)')
147 & ' MDS_READ_FIELD: invalid sub-set of levels'
148 CALL PRINT_ERROR( msgBuf, myThid )
149 STOP 'ABNORMAL END: S/R MDS_READ_FIELD'
150 ENDIF
151
152 C Assign special directory
153 IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN
154 pfName= fName
155 ELSE
156 WRITE(pfName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
157 ENDIF
158 pIL=ILNBLNK( pfName )
159
160 C Assign a free unit number as the I/O channel for this routine
161 CALL MDSFINDUNIT( dUnit, myThid )
162
163 C Check first for global file with simple name (ie. fName)
164 dataFName = fName
165 INQUIRE( file=dataFName, exist=exst )
166 IF (exst) THEN
167 IF ( debugLevel .GE. debLevA ) THEN
168 WRITE(msgBuf,'(A,A)')
169 & ' MDS_READ_FIELD: opening global file: ',dataFName(1:IL)
170 #ifndef ALLOW_ECCO
171 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
172 & SQUEEZE_RIGHT , myThid)
173 #endif
174 ENDIF
175 globalFile = .TRUE.
176 ENDIF
177
178 C If negative check for global file with MDS name (ie. fName.data)
179 IF (.NOT. globalFile) THEN
180 WRITE(dataFName,'(2a)') fName(1:IL),'.data'
181 INQUIRE( file=dataFName, exist=exst )
182 IF (exst) THEN
183 IF ( debugLevel .GE. debLevA ) THEN
184 WRITE(msgBuf,'(A,A)')
185 & ' MDS_READ_FIELD: opening global file: ',dataFName(1:IL+5)
186 #ifndef ALLOW_ECCO
187 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
188 & SQUEEZE_RIGHT , myThid)
189 #endif
190 ENDIF
191 globalFile = .TRUE.
192 ENDIF
193 ENDIF
194
195 C- endif iAmDoingIO
196 ENDIF
197
198 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
199
200 IF ( useSingleCPUIO ) THEN
201
202 C master thread of process 0, only, opens a global file
203 IF ( iAmDoingIO ) THEN
204 C If global file is visible to process 0, then open it here.
205 C Otherwise stop program.
206 IF ( globalFile) THEN
207 length_of_rec=MDS_RECLEN( filePrec, xSize*ySize, myThid )
208 OPEN( dUnit, file=dataFName, status='old',
209 & access='direct', recl=length_of_rec )
210 ELSE
211 WRITE(msgBuf,'(2A)')
212 & ' MDS_READ_FIELD: filename: ', dataFName(1:IL+5)
213 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
214 & SQUEEZE_RIGHT , myThid)
215 CALL PRINT_ERROR( msgBuf, myThid )
216 WRITE(msgBuf,'(A)')
217 & ' MDS_READ_FIELD: File does not exist'
218 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
219 & SQUEEZE_RIGHT , myThid)
220 CALL PRINT_ERROR( msgBuf, myThid )
221 STOP 'ABNORMAL END: S/R MDS_READ_FIELD'
222 ENDIF
223 C- endif iAmDoingIO
224 ENDIF
225
226 DO k=kLo,kHi
227
228 C master thread of process 0, only, read from file
229 IF ( iAmDoingIO ) THEN
230 irec = k+1-kLo+nNz*(irecord-1)
231 IF (filePrec .EQ. precFloat32) THEN
232 READ(dUnit,rec=irec) ( xy_buffer_r4(i),i=1,xSize*ySize )
233 #ifdef _BYTESWAPIO
234 CALL MDS_BYTESWAPR4( xSize*ySize, xy_buffer_r4 )
235 #endif
236 ELSEIF (filePrec .EQ. precFloat64) THEN
237 READ(dUnit,rec=irec) ( xy_buffer_r8(i),i=1,xSize*ySize )
238 #ifdef _BYTESWAPIO
239 CALL MDS_BYTESWAPR8( xSize*ySize, xy_buffer_r8 )
240 #endif
241 ELSE
242 WRITE(msgBuf,'(A)')
243 & ' MDS_READ_FIELD: illegal value for filePrec'
244 CALL PRINT_ERROR( msgBuf, myThid )
245 STOP 'ABNORMAL END: S/R MDS_READ_FIELD'
246 ENDIF
247 C Map the appropriate global io-buffer to global model (real*8) array
248 CALL MDS_MAP_GLOBAL(
249 U xy_buffer_r4, xy_buffer_r8,
250 U globalBuf,
251 I xSize, ySize, filePrec,
252 I .TRUE., .FALSE. )
253 C- endif iAmDoingIO
254 ENDIF
255 CALL SCATTER_2D(globalBuf,sharedLocalBuf,myThid)
256 IF (arrType .EQ. 'RS') THEN
257 CALL MDS_PASStoRS( sharedLocalBuf,arr,k,kSize,.TRUE.,myThid )
258 ELSEIF (arrType .EQ. 'RL') THEN
259 CALL MDS_PASStoRL( sharedLocalBuf,arr,k,kSize,.TRUE.,myThid )
260 ELSE
261 WRITE(msgBuf,'(A)')
262 & ' MDS_READ_FIELD: illegal value for arrType'
263 CALL PRINT_ERROR( msgBuf, myThid )
264 STOP 'ABNORMAL END: S/R MDS_READ_FIELD'
265 ENDIF
266
267 ENDDO
268 c ENDDO k=kLo,kHi
269
270 IF ( iAmDoingIO ) THEN
271 CLOSE( dUnit )
272 ENDIF
273
274 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
275 C--- else .NOT.useSingleCpuIO
276 ELSE
277
278 C Only do I/O if I am the master thread
279 IF ( iAmDoingIO ) THEN
280
281 C If we are reading from a global file then we open it here
282 IF (globalFile) THEN
283 length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )
284 OPEN( dUnit, file=dataFName, status='old',
285 & access='direct', recl=length_of_rec )
286 fileIsOpen=.TRUE.
287 ENDIF
288
289 C Loop over all tiles
290 DO bj=1,nSy
291 DO bi=1,nSx
292 C If we are reading from a tiled MDS file then we open each one here
293 IF (.NOT. globalFile) THEN
294 iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
295 jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
296 WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
297 & pfName(1:pIL),'.',iG,'.',jG,'.data'
298 INQUIRE( file=dataFName, exist=exst )
299 C Of course, we only open the file if the tile is "active"
300 C (This is a place-holder for the active/passive mechanism
301 IF (exst) THEN
302 IF ( debugLevel .GE. debLevA ) THEN
303 WRITE(msgBuf,'(A,A)')
304 & ' MDS_READ_FIELD: opening file: ',dataFName(1:pIL+13)
305 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
306 & SQUEEZE_RIGHT , myThid)
307 ENDIF
308 length_of_rec=MDS_RECLEN( filePrec, sNx, myThid )
309 OPEN( dUnit, file=dataFName, status='old',
310 & access='direct', recl=length_of_rec )
311 fileIsOpen=.TRUE.
312 ELSE
313 fileIsOpen=.FALSE.
314 WRITE(msgBuf,'(4A)') ' MDS_READ_FIELD: filename: ',
315 & fName(1:IL),' , ', dataFName(1:pIL+13)
316 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
317 & SQUEEZE_RIGHT , myThid)
318 CALL PRINT_ERROR( msgBuf, myThid )
319 WRITE(msgBuf,'(A)')
320 & ' MDS_READ_FIELD: Files DO not exist'
321 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
322 & SQUEEZE_RIGHT , myThid)
323 CALL PRINT_ERROR( msgBuf, myThid )
324 STOP 'ABNORMAL END: S/R MDS_READ_FIELD'
325 ENDIF
326 ENDIF
327
328 IF (fileIsOpen) THEN
329 tNy = sNy
330 #ifdef ALLOW_EXCH2
331 tN = W2_myTileList(bi)
332 tGy = exch2_tyGlobalo(tN)
333 tGx = exch2_txGlobalo(tN)
334 tNy = exch2_tNy(tN)
335 tNx = exch2_tNx(tN)
336 IF ( exch2_mydNx(tN) .GT. xSize ) THEN
337 C- face x-size larger than glob-size : fold it
338 iGjLoc = 0
339 jGjLoc = exch2_mydNx(tN) / xSize
340 ELSEIF ( exch2_tNy(tN) .GT. ySize ) THEN
341 C- tile y-size larger than glob-size : make a long line
342 iGjLoc = exch2_mydNx(tN)
343 jGjLoc = 0
344 ELSE
345 C- default (face fit into global-IO-array)
346 iGjLoc = 0
347 jGjLoc = 1
348 ENDIF
349 global_nTx = exch2_global_Nx/tNx
350 #endif /* ALLOW_EXCH2 */
351 DO k=kLo,kHi
352 DO j=1,tNy
353 IF (globalFile) THEN
354 #ifdef ALLOW_EXCH2
355 irec = 1 + ( tGx-1 + (j-1)*iGjLoc )/tNx
356 & + ( tGy-1 + (j-1)*jGjLoc )*global_nTx
357 & + ( k-kLo + (irecord-1)*nNz
358 & )*ySize*global_nTx
359 #else /* ALLOW_EXCH2 */
360 iG = myXGlobalLo-1 + (bi-1)*sNx
361 jG = myYGlobalLo-1 + (bj-1)*sNy
362 irec= 1 + INT(iG/sNx) + nSx*nPx*(jG+j-1)
363 & + nSx*nPx*Ny*(k-kLo)
364 & + nSx*nPx*Ny*nNz*(irecord-1)
365 #endif /* ALLOW_EXCH2 */
366 ELSE
367 irec=j + sNy*(k-kLo) + sNy*nNz*(irecord-1)
368 ENDIF
369 IF (filePrec .EQ. precFloat32) THEN
370 READ(dUnit,rec=irec) r4seg
371 #ifdef _BYTESWAPIO
372 CALL MDS_BYTESWAPR4( sNx, r4seg )
373 #endif
374 IF (arrType .EQ. 'RS') THEN
375 CALL MDS_SEG4toRS( j,bi,bj,k,kSize, r4seg, .TRUE., arr )
376 ELSEIF (arrType .EQ. 'RL') THEN
377 CALL MDS_SEG4toRL( j,bi,bj,k,kSize, r4seg, .TRUE., arr )
378 ELSE
379 WRITE(msgBuf,'(A)')
380 & ' MDS_READ_FIELD: illegal value for arrType'
381 CALL PRINT_ERROR( msgBuf, myThid )
382 STOP 'ABNORMAL END: S/R MDS_READ_FIELD'
383 ENDIF
384 ELSEIF (filePrec .EQ. precFloat64) THEN
385 READ(dUnit,rec=irec) r8seg
386 #ifdef _BYTESWAPIO
387 CALL MDS_BYTESWAPR8( sNx, r8seg )
388 #endif
389 IF (arrType .EQ. 'RS') THEN
390 CALL MDS_SEG8toRS( j,bi,bj,k,kSize, r8seg, .TRUE., arr )
391 ELSEIF (arrType .EQ. 'RL') THEN
392 CALL MDS_SEG8toRL( j,bi,bj,k,kSize, r8seg, .TRUE., arr )
393 ELSE
394 WRITE(msgBuf,'(A)')
395 & ' MDS_READ_FIELD: illegal value for arrType'
396 CALL PRINT_ERROR( msgBuf, myThid )
397 STOP 'ABNORMAL END: S/R MDS_READ_FIELD'
398 ENDIF
399 ELSE
400 WRITE(msgBuf,'(A)')
401 & ' MDS_READ_FIELD: illegal value for filePrec'
402 CALL PRINT_ERROR( msgBuf, myThid )
403 STOP 'ABNORMAL END: S/R MDS_READ_FIELD'
404 ENDIF
405 C End of j loop
406 ENDDO
407 C End of k loop
408 ENDDO
409 C end if fileIsOpen
410 ENDIF
411 IF (fileIsOpen .AND. (.NOT. globalFile)) THEN
412 CLOSE( dUnit )
413 fileIsOpen = .FALSE.
414 ENDIF
415 C End of bi,bj loops
416 ENDDO
417 ENDDO
418
419 C If global file was opened then close it
420 IF (fileIsOpen .AND. globalFile) THEN
421 CLOSE( dUnit )
422 fileIsOpen = .FALSE.
423 ENDIF
424
425 C- endif iAmDoingIO
426 ENDIF
427
428 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
429 C if useSingleCpuIO / else / end
430 ENDIF
431
432 RETURN
433 END

  ViewVC Help
Powered by ViewVC 1.1.22