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

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

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


Revision 1.1 - (show annotations) (download)
Tue Sep 1 19:16:51 2009 UTC (14 years, 8 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint62, checkpoint62c, checkpoint62b, checkpoint62a, checkpoint61v, checkpoint61w, checkpoint61z, checkpoint61x, checkpoint61y
Section (or vertical slice) IO:
 - new S/R with argument "useCurrentDir" to combine default & _loc version.
 - keep old version in file "mdsio_rw_slice.F"
 - take set of 4 simple SEGxtoRx_2D S/R out of "mdsio_slice.F" file into
   specific file "mdsio_segxtorx_2d.F"
 - separated files for section reading (mdsio_read_section.F) and writing
    (mdsio_write_section.F).

1 C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_slice.F,v 1.13 2009/08/05 23:17:54 jmc Exp $
2 C $Name: $
3
4 #include "MDSIO_OPTIONS.h"
5
6 C-- File mdsio_read_section.F: Routines to handle mid-level I/O interface.
7 C-- Contents
8 C-- o MDS_WRITE_SEC_XZ
9 C-- o MDS_WRITE_SEC_YZ
10
11 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
12
13 CBOP
14 C !ROUTINE: MDS_WRITE_SEC_XZ
15 C !INTERFACE:
16 SUBROUTINE MDS_WRITE_SEC_XZ(
17 I fName,
18 I filePrec,
19 I globalFile,
20 I useCurrentDir,
21 I arrType,
22 I kSize,
23 I fldRL, fldRS,
24 I irecord,
25 I myIter,
26 I myThid )
27
28 C !DESCRIPTION
29 C Arguments:
30 C
31 C fName string :: base name for file to read
32 C filePrec integer :: number of bits per word in file (32 or 64)
33 C globalFile logical :: selects between writing a global or tiled file
34 C useCurrentDir logic :: always write to the current directory (even if
35 C "mdsioLocalDir" is set)
36 C arrType char(2) :: which array (fldRL/RS) to write, either "RL" or "RS
37 C kSize integer :: size of third dimension, normally either 1 or Nr
38 C fldRL RL :: array to write if arrType="RL", fldRL(:,kSize,:,:)
39 C fldRS RS :: array to write if arrType="RS", fldRS(:,kSize,:,:)
40 C irecord integer :: record number to read
41 C myIter integer :: time step number
42 C myThid integer :: thread identifier
43 C
44 C MDS_WRITE_SEC_XZ creates either a file of the form "fName.data"
45 C if the logical flag "globalFile" is set true. Otherwise
46 C it creates MDS tiled files of the form "fName.xxx.yyy.data".
47 C The precision of the file is decsribed by filePrec, set either
48 C to floatPrec32 or floatPrec64. The char*(2) string arrType, either "RL"
49 C or "RS", selects which array is written, either fldRL or fldRS.
50 C This routine writes vertical slices (X-Z) including overlap regions.
51 C irecord is the record number to be read and must be >= 1.
52 C NOTE: It is currently assumed that
53 C the highest record number in the file was the last record written.
54 C
55 C Modified: 06/02/00 spk@ocean.mit.edu
56 CEOP
57
58 C !USES:
59 IMPLICIT NONE
60 C Global variables / common blocks
61 #include "SIZE.h"
62 #include "EEPARAMS.h"
63 #include "PARAMS.h"
64
65 C !INPUT PARAMETERS:
66 CHARACTER*(*) fName
67 INTEGER filePrec
68 LOGICAL globalFile
69 LOGICAL useCurrentDir
70 CHARACTER*(2) arrType
71 INTEGER kSize
72 _RL fldRL(*)
73 _RS fldRS(*)
74 INTEGER irecord
75 INTEGER myIter
76 INTEGER myThid
77 C !OUTPUT PARAMETERS:
78
79 C !FUNCTIONS:
80 INTEGER ILNBLNK
81 INTEGER MDS_RECLEN
82 EXTERNAL ILNBLNK, MDS_RECLEN
83
84 C !LOCAL VARIABLES:
85 CHARACTER*(MAX_LEN_FNAM) dataFName,pfName
86 INTEGER iG,jG,irec,bi,bj,k,dUnit,IL,pIL
87 Real*4 r4seg(sNx)
88 Real*8 r8seg(sNx)
89 INTEGER length_of_rec
90 LOGICAL fileIsOpen
91 CHARACTER*(max_len_mbuf) msgBuf
92 C ------------------------------------------------------------------
93
94 C Only do I/O if I am the master thread
95 _BEGIN_MASTER( myThid )
96
97 C Record number must be >= 1
98 IF (irecord .LT. 1) THEN
99 WRITE(msgBuf,'(A,I9.8)')
100 & ' MDS_WRITE_SEC_XZ: argument irecord = ',irecord
101 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
102 & SQUEEZE_RIGHT, myThid )
103 WRITE(msgBuf,'(A)')
104 & ' MDS_WRITE_SEC_XZ: invalid value for irecord'
105 CALL PRINT_ERROR( msgBuf, myThid )
106 STOP 'ABNORMAL END: S/R MDS_WRITE_SEC_XZ'
107 ENDIF
108
109 C Assume nothing
110 fileIsOpen=.FALSE.
111 IL = ILNBLNK( fName )
112 pIL = ILNBLNK( mdsioLocalDir )
113
114 C Assign special directory
115 IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN
116 pfName= fName
117 ELSE
118 WRITE(pfName,'(2A)') mdsioLocalDir(1:pIL), fName(1:IL)
119 ENDIF
120 pIL=ILNBLNK( pfName )
121
122 C Assign a free unit number as the I/O channel for this routine
123 CALL MDSFINDUNIT( dUnit, myThid )
124
125 C If we are writing to a global file then we open it here
126 IF (globalFile) THEN
127 WRITE(dataFName,'(2A)') fName(1:IL),'.data'
128 IF (irecord .EQ. 1) THEN
129 length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )
130 OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
131 & access='direct', recl=length_of_rec )
132 fileIsOpen=.TRUE.
133 ELSE
134 length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )
135 OPEN( dUnit, file=dataFName, status='old',
136 & access='direct', recl=length_of_rec )
137 fileIsOpen=.TRUE.
138 ENDIF
139 ENDIF
140
141 C Loop over all tiles
142 DO bj=1,nSy
143 DO bi=1,nSx
144 C If we are writing to a tiled MDS file then we open each one here
145 IF (.NOT. globalFile) THEN
146 iG=bi+(myXGlobalLo-1)/sNx
147 jG=bj+(myYGlobalLo-1)/sNy
148 WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
149 & pfName(1:pIL),'.',iG,'.',jG,'.data'
150 IF (irecord .EQ. 1) THEN
151 length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )
152 OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
153 & access='direct', recl=length_of_rec )
154 fileIsOpen=.TRUE.
155 ELSE
156 length_of_rec = MDS_RECLEN( filePrec, sNx, myThid )
157 OPEN( dUnit, file=dataFName, status='old',
158 & access='direct', recl=length_of_rec )
159 fileIsOpen=.TRUE.
160 ENDIF
161 ENDIF
162 IF (fileIsOpen) THEN
163 DO k=1,kSize
164 IF (globalFile) THEN
165 iG = myXGlobalLo-1 + (bi-1)*sNx
166 jG = (myYGlobalLo-1)/sNy + (bj-1)
167 irec=1 + INT(iG/sNx) + nSx*nPx*(k-1)
168 & + nSx*nPx*kSize*(irecord-1)
169 ELSE
170 iG = 0
171 jG = 0
172 irec=k + kSize*(irecord-1)
173 ENDIF
174 IF (filePrec .EQ. precFloat32) THEN
175 IF (arrType .EQ. 'RS') THEN
176 CALL MDS_SEG4toRS_2D( sNx,oLx,kSize,bi,bj,k,.FALSE.,
177 & r4seg,fldRS )
178 ELSEIF (arrType .EQ. 'RL') THEN
179 CALL MDS_SEG4toRL_2D( sNx,oLx,kSize,bi,bj,k,.FALSE.,
180 & r4seg,fldRL )
181 ELSE
182 WRITE(msgBuf,'(A)')
183 & ' MDS_WRITE_SEC_XZ: illegal value for arrType'
184 CALL PRINT_ERROR( msgBuf, myThid )
185 STOP 'ABNORMAL END: S/R MDS_WRITE_SEC_XZ'
186 ENDIF
187 #ifdef _BYTESWAPIO
188 CALL MDS_BYTESWAPR4(sNx,r4seg)
189 #endif
190 WRITE(dUnit,rec=irec) r4seg
191 ELSEIF (filePrec .EQ. precFloat64) THEN
192 IF (arrType .EQ. 'RS') THEN
193 CALL MDS_SEG8toRS_2D( sNx,oLx,kSize,bi,bj,k,.FALSE.,
194 & r8seg,fldRS )
195 ELSEIF (arrType .EQ. 'RL') THEN
196 CALL MDS_SEG8toRL_2D( sNx,oLx,kSize,bi,bj,k,.FALSE.,
197 & r8seg,fldRL )
198 ELSE
199 WRITE(msgBuf,'(A)')
200 & ' MDS_WRITE_SEC_XZ: illegal value for arrType'
201 CALL PRINT_ERROR( msgBuf, myThid )
202 STOP 'ABNORMAL END: S/R MDS_WRITE_SEC_XZ'
203 ENDIF
204 #ifdef _BYTESWAPIO
205 CALL MDS_BYTESWAPR8( sNx, r8seg )
206 #endif
207 WRITE(dUnit,rec=irec) r8seg
208 ELSE
209 WRITE(msgBuf,'(A)')
210 & ' MDS_WRITE_SEC_XZ: illegal value for filePrec'
211 CALL PRINT_ERROR( msgBuf, myThid )
212 STOP 'ABNORMAL END: S/R MDS_WRITE_SEC_XZ'
213 ENDIF
214 C End of k loop
215 ENDDO
216 ELSE
217 WRITE(msgBuf,'(A)')
218 & ' MDS_WRITE_SEC_XZ: I should never get to this point'
219 CALL PRINT_ERROR( msgBuf, myThid )
220 STOP 'ABNORMAL END: S/R MDS_WRITE_SEC_XZ'
221 ENDIF
222 C If we were writing to a tiled MDS file then we close it here
223 IF (fileIsOpen .AND. (.NOT. globalFile)) THEN
224 CLOSE( dUnit )
225 fileIsOpen = .FALSE.
226 ENDIF
227 C End of bi,bj loops
228 ENDDO
229 ENDDO
230
231 C If global file was opened then close it
232 IF (fileIsOpen .AND. globalFile) THEN
233 CLOSE( dUnit )
234 fileIsOpen = .FALSE.
235 ENDIF
236
237 _END_MASTER( myThid )
238
239 C ------------------------------------------------------------------
240 RETURN
241 END
242
243 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
244
245 CBOP
246 C !ROUTINE: MDS_WRITE_SEC_YZ
247 C !INTERFACE:
248 SUBROUTINE MDS_WRITE_SEC_YZ(
249 I fName,
250 I filePrec,
251 I globalFile,
252 I useCurrentDir,
253 I arrType,
254 I kSize,
255 I fldRL, fldRS,
256 I irecord,
257 I myIter,
258 I myThid )
259
260 C !DESCRIPTION
261 C Arguments:
262 C
263 C fName string :: base name for file to read
264 C filePrec integer :: number of bits per word in file (32 or 64)
265 C globalFile logical :: selects between writing a global or tiled file
266 C useCurrentDir logic :: always write to the current directory (even if
267 C "mdsioLocalDir" is set)
268 C arrType char(2) :: which array (fldRL/RS) to write, either "RL" or "RS
269 C kSize integer :: size of third dimension, normally either 1 or Nr
270 C fldRL RL :: array to write if arrType="RL", fldRL(:,kSize,:,:)
271 C fldRS RS :: array to write if arrType="RS", fldRS(:,kSize,:,:)
272 C irecord integer :: record number to read
273 C myIter integer :: time step number
274 C myThid integer :: thread identifier
275 C
276 C MDS_WRITE_SEC_YZ creates either a file of the form "fName.data"
277 C if the logical flag "globalFile" is set true. Otherwise
278 C it creates MDS tiled files of the form "fName.xxx.yyy.data".
279 C The precision of the file is decsribed by filePrec, set either
280 C to floatPrec32 or floatPrec64. The char*(2) string arrType, either "RL"
281 C or "RS", selects which array is written, either fldRL or fldRS.
282 C This routine writes vertical slices (Y-Z) including overlap regions.
283 C irecord is the record number to be read and must be >= 1.
284 C NOTE: It is currently assumed that
285 C the highest record number in the file was the last record written.
286 C
287 C Modified: 06/02/00 spk@ocean.mit.edu
288 CEOP
289
290 C !USES:
291 IMPLICIT NONE
292 C Global variables / common blocks
293 #include "SIZE.h"
294 #include "EEPARAMS.h"
295 #include "PARAMS.h"
296
297 C !INPUT PARAMETERS:
298 CHARACTER*(*) fName
299 INTEGER filePrec
300 LOGICAL globalFile
301 LOGICAL useCurrentDir
302 CHARACTER*(2) arrType
303 INTEGER kSize
304 _RL fldRL(*)
305 _RS fldRS(*)
306 INTEGER irecord
307 INTEGER myIter
308 INTEGER myThid
309 C !OUTPUT PARAMETERS:
310
311 C !FUNCTIONS:
312 INTEGER ILNBLNK
313 INTEGER MDS_RECLEN
314 EXTERNAL ILNBLNK, MDS_RECLEN
315
316 C !LOCAL VARIABLES:
317 CHARACTER*(MAX_LEN_FNAM) dataFName,pfName
318 INTEGER iG,jG,irec,bi,bj,k,dUnit,IL,pIL
319 Real*4 r4seg(sNy)
320 Real*8 r8seg(sNy)
321 INTEGER length_of_rec
322 LOGICAL fileIsOpen
323 CHARACTER*(max_len_mbuf) msgBuf
324 C ------------------------------------------------------------------
325
326 C Only do I/O if I am the master thread
327 _BEGIN_MASTER( myThid )
328
329 C Record number must be >= 1
330 IF (irecord .LT. 1) THEN
331 WRITE(msgBuf,'(A,I9.8)')
332 & ' MDS_WRITE_SEC_YZ: argument irecord = ',irecord
333 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
334 & SQUEEZE_RIGHT , myThid)
335 WRITE(msgBuf,'(A)')
336 & ' MDS_WRITE_SEC_YZ: invalid value for irecord'
337 CALL PRINT_ERROR( msgBuf, myThid )
338 STOP 'ABNORMAL END: S/R MDS_WRITE_SEC_YZ'
339 ENDIF
340
341 C Assume nothing
342 fileIsOpen=.FALSE.
343 IL = ILNBLNK( fName )
344 pIL = ILNBLNK( mdsioLocalDir )
345
346 C Assign special directory
347 IF ( useCurrentDir .OR. pIL.EQ.0 ) THEN
348 pfName= fName
349 ELSE
350 WRITE(pfName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
351 ENDIF
352 pIL=ILNBLNK( pfName )
353
354 C Assign a free unit number as the I/O channel for this routine
355 CALL MDSFINDUNIT( dUnit, myThid )
356
357 C If we are writing to a global file then we open it here
358 IF (globalFile) THEN
359 WRITE(dataFName,'(2A)') fName(1:IL),'.data'
360 IF (irecord .EQ. 1) THEN
361 length_of_rec = MDS_RECLEN( filePrec, sNy, myThid )
362 OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
363 & access='direct', recl=length_of_rec )
364 fileIsOpen=.TRUE.
365 ELSE
366 length_of_rec = MDS_RECLEN( filePrec, sNy, myThid )
367 OPEN( dUnit, file=dataFName, status='old',
368 & access='direct', recl=length_of_rec )
369 fileIsOpen=.TRUE.
370 ENDIF
371 ENDIF
372
373 C Loop over all tiles
374 DO bj=1,nSy
375 DO bi=1,nSx
376 C If we are writing to a tiled MDS file then we open each one here
377 IF (.NOT. globalFile) THEN
378 iG=bi+(myXGlobalLo-1)/sNx
379 jG=bj+(myYGlobalLo-1)/sNy
380 WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
381 & pfName(1:pIL),'.',iG,'.',jG,'.data'
382 IF (irecord .EQ. 1) THEN
383 length_of_rec = MDS_RECLEN( filePrec, sNy, myThid )
384 OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
385 & access='direct', recl=length_of_rec )
386 fileIsOpen=.TRUE.
387 ELSE
388 length_of_rec = MDS_RECLEN( filePrec, sNy, myThid )
389 OPEN( dUnit, file=dataFName, status='old',
390 & access='direct', recl=length_of_rec )
391 fileIsOpen=.TRUE.
392 ENDIF
393 ENDIF
394 IF (fileIsOpen) THEN
395 DO k=1,kSize
396 IF (globalFile) THEN
397 iG = (myXGlobalLo-1)/sNx + (bi-1)
398 jG = myYGlobalLo-1 + (bj-1)*sNy
399 irec=1 + INT(jG/sNy) + nSy*nPy*(k-1)
400 & + nSy*nPy*kSize*(irecord-1)
401 ELSE
402 iG = 0
403 jG = 0
404 irec=k + kSize*(irecord-1)
405 ENDIF
406 IF (filePrec .EQ. precFloat32) THEN
407 IF (arrType .EQ. 'RS') THEN
408 CALL MDS_SEG4toRS_2D( sNy,oLy,kSize,bi,bj,k,.FALSE.,
409 & r4seg,fldRS )
410 ELSEIF (arrType .EQ. 'RL') THEN
411 CALL MDS_SEG4toRL_2D( sNy,oLy,kSize,bi,bj,k,.FALSE.,
412 & r4seg,fldRL )
413 ELSE
414 WRITE(msgBuf,'(A)')
415 & ' MDS_WRITE_SEC_YZ: illegal value for arrType'
416 CALL PRINT_ERROR( msgBuf, myThid )
417 STOP 'ABNORMAL END: S/R MDS_WRITE_SEC_YZ'
418 ENDIF
419 #ifdef _BYTESWAPIO
420 CALL MDS_BYTESWAPR4(sNy,r4seg)
421 #endif
422 WRITE(dUnit,rec=irec) r4seg
423 ELSEIF (filePrec .EQ. precFloat64) THEN
424 IF (arrType .EQ. 'RS') THEN
425 CALL MDS_SEG8toRS_2D( sNy,oLy,kSize,bi,bj,k,.FALSE.,
426 & r8seg,fldRS )
427 ELSEIF (arrType .EQ. 'RL') THEN
428 CALL MDS_SEG8toRL_2D( sNy,oLy,kSize,bi,bj,k,.FALSE.,
429 & r8seg,fldRL )
430 ELSE
431 WRITE(msgBuf,'(A)')
432 & ' MDS_WRITE_SEC_YZ: illegal value for arrType'
433 CALL PRINT_ERROR( msgBuf, myThid )
434 STOP 'ABNORMAL END: S/R MDS_WRITE_SEC_YZ'
435 ENDIF
436 #ifdef _BYTESWAPIO
437 CALL MDS_BYTESWAPR8( sNy, r8seg )
438 #endif
439 WRITE(dUnit,rec=irec) r8seg
440 ELSE
441 WRITE(msgBuf,'(A)')
442 & ' MDS_WRITE_SEC_YZ: illegal value for filePrec'
443 CALL PRINT_ERROR( msgBuf, myThid )
444 STOP 'ABNORMAL END: S/R MDS_WRITE_SEC_YZ'
445 ENDIF
446 C End of k loop
447 ENDDO
448 ELSE
449 WRITE(msgBuf,'(A)')
450 & ' MDS_WRITE_SEC_YZ: I should never get to this point'
451 CALL PRINT_ERROR( msgBuf, myThid )
452 STOP 'ABNORMAL END: S/R MDS_WRITE_SEC_YZ'
453 ENDIF
454 C If we were writing to a tiled MDS file then we close it here
455 IF (fileIsOpen .AND. (.NOT. globalFile)) THEN
456 CLOSE( dUnit )
457 fileIsOpen = .FALSE.
458 ENDIF
459 C End of bi,bj loops
460 ENDDO
461 ENDDO
462
463 C If global file was opened then close it
464 IF (fileIsOpen .AND. globalFile) THEN
465 CLOSE( dUnit )
466 fileIsOpen = .FALSE.
467 ENDIF
468
469 _END_MASTER( myThid )
470
471 C ------------------------------------------------------------------
472 RETURN
473 END

  ViewVC Help
Powered by ViewVC 1.1.22