/[MITgcm]/MITgcm/eesupp/src/dfile.F
ViewVC logotype

Contents of /MITgcm/eesupp/src/dfile.F

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

Revision 1.12 - (show annotations) (download)
Sat Mar 27 03:51:50 2004 UTC (20 years, 2 months ago) by edhill
Branch: MAIN
CVS Tags: checkpoint57m_post, checkpoint57g_pre, checkpoint57s_post, checkpoint58b_post, checkpoint57b_post, checkpoint57g_post, checkpoint56b_post, checkpoint57y_post, checkpoint54d_post, checkpoint54e_post, checkpoint57r_post, checkpoint57d_post, checkpoint57i_post, checkpoint59, checkpoint58, checkpoint55, checkpoint54, checkpoint57, checkpoint56, checkpoint53, checkpoint58f_post, checkpoint57n_post, checkpoint58d_post, checkpoint58a_post, checkpoint57z_post, checkpoint54f_post, checkpoint58y_post, checkpoint55a_post, checkpoint58t_post, checkpoint55i_post, checkpoint57l_post, checkpoint57h_post, checkpoint57t_post, checkpoint55c_post, checkpoint57v_post, checkpoint57f_post, checkpoint53d_post, checkpoint60, checkpoint61, checkpoint57a_post, checkpoint57h_pre, checkpoint57x_post, checkpoint54b_post, checkpoint58w_post, checkpoint52m_post, checkpoint57y_pre, checkpoint55g_post, checkpoint58o_post, checkpoint57c_post, checkpoint58p_post, checkpoint58q_post, checkpoint55d_post, checkpoint58e_post, checkpoint58m_post, checkpoint53c_post, checkpoint55d_pre, checkpoint57c_pre, checkpoint58r_post, checkpoint55j_post, checkpoint54a_post, checkpoint55h_post, checkpoint58n_post, checkpoint57e_post, checkpoint55b_post, checkpoint53a_post, checkpoint59q, checkpoint59p, checkpoint59r, checkpoint59e, checkpoint59d, checkpoint59g, checkpoint59f, checkpoint59a, checkpoint55f_post, checkpoint59c, checkpoint59b, checkpoint59m, checkpoint59l, checkpoint59o, checkpoint59n, checkpoint59i, checkpoint59h, checkpoint59k, checkpoint53g_post, checkpoint57p_post, checkpint57u_post, checkpoint57q_post, mitgcm_mapl_00, eckpoint57e_pre, checkpoint58k_post, checkpoint58v_post, checkpoint56a_post, checkpoint58l_post, checkpoint53f_post, checkpoint54a_pre, checkpoint53b_pre, checkpoint57h_done, checkpoint57j_post, checkpoint57f_pre, checkpoint61f, checkpoint58g_post, checkpoint58x_post, checkpoint52n_post, checkpoint59j, checkpoint58h_post, checkpoint56c_post, checkpoint58j_post, checkpoint57a_pre, checkpoint57o_post, checkpoint57k_post, checkpoint53b_post, checkpoint57w_post, checkpoint61e, checkpoint58i_post, checkpoint58c_post, checkpoint58u_post, checkpoint53d_pre, checkpoint58s_post, checkpoint55e_post, checkpoint61g, checkpoint61d, checkpoint54c_post, checkpoint61b, checkpoint61c, checkpoint61a, checkpoint61l, checkpoint61j, checkpoint61k, checkpoint61h, checkpoint61i
Changes since 1.11: +3 -3 lines 
 o cleanup comments (NO CODE CHANGES) in eesupp for protex
 o the "api reference" framework now builds documentation for:
     eesupp, pkg/generic_advdiff, and pkg/gmredi
 o remove mnc from the default gfd in pkg_groups pending
     further testing on systems where NetCDF is not installed
1 C $Header: /u/gcmpack/MITgcm/eesupp/src/dfile.F,v 1.11 2001/02/04 14:38:42 cnh Exp $
2 C $Name: $
3
4 #include "CPP_EEOPTIONS.h"
5
6 C-- File dfile.F: Routines that handle actual I/O
7 C-- to model "dump" files.
8 C-- These low-level routines could be replaced
9 C-- by platform/environment specific C or
10 C-- MPI-2 routines one day! In some situations the
11 C-- functionality of these low-level routines is
12 C-- encompassed by the data handling package. For
13 C-- example netCDF provides primitive that are
14 C-- higher level
15 C-- Contents
16 C-- DFILE_CLOSE - Closes dump file
17 C-- DFILE_INIT - Initialisation procedure for subsequent DFILE
18 C data-structures. Only called once per run.
19 C-- DFILE_OPEN - Opens dump file
20 C-- DFILE_READ_R8 - Reads from a dump file
21 C-- DFILE_READ_R4 - Reads from a dump file
22 C-- DFILE_SET_RO - Sets new connections to be read-only
23 C-- DFILE_SET_RW - Sets new connections to be read-write
24 C-- DFILE_SET_STOP_ON_ERROR - Sets new connections to STOP on error
25 C-- DFILE_SET_CONT_ON_ERROR - Sets new connections to continue
26 C on error
27 C-- DFILE_WRITE_R4 - Writes to a dump file
28 C-- DFILE_WRITE_R8 - Writes to a dump file
29 C
30 C Notes:
31 C ======
32 C The default behaviour is for the model to stop if an
33 C input errors occur but to continue if output errors occur.
34 C However, this policy is not enforced in these low-level routines.
35 C Instead these routines are coded to allow either continue
36 C on error or stop on error. Which action is taken
37 C is controlled via a mode flag which is set from the higher
38 C level calls to these routines. A mode flag is also used to
39 C control whether the DFILE_OPEN routine opens a file in
40 C read-write or read-only mode. On some systems this is necessary
41 C as the default is read-write and will fail for read-only files or
42 C file systems. Other systems do not support the OPEN(...='READ_ONLY')
43 C so this feature may need to be switched on or off as appropriate.
44 C The DFILE_SET routines provide this mechanism. They work by setting
45 C a "context" flag which is applied to IO ahndles when the DFILE_OPEN
46 C call is made. IO handles that are already open are not affected by
47 C subsequent calls to DFILE_SET routines.
48
49 SUBROUTINE DFILE_CLOSE(
50 I fileHandle, myThid)
51 C /==========================================================\
52 C | SUBROUTINE DFILE\_CLOSE |
53 C | o Close model "dump" file. |
54 C |==========================================================|
55 C | Controlling routine for doing actual I/O operations. |
56 C | Close the file referred to by handle fielHandle. |
57 C \==========================================================/
58 IMPLICIT NONE
59
60 C == Global variables ==
61 #include "SIZE.h"
62 #include "EEPARAMS.h"
63 #include "EESUPPORT.h"
64 #include "DFILE.h"
65
66 C == Routine arguments ==
67 INTEGER myThid
68 INTEGER fileHandle
69
70 #ifdef USE_DFILE
71
72 C == Local variables ==
73 C msgBuf - Error message buffer
74 C I - Work variables
75 C dUnit Data unit
76 C mUnit Meta data unit
77 C eMode Error mode
78 CHARACTER*(MAX_LEN_MBUF) msgBuf
79 INTEGER I
80 INTEGER dUnit
81 INTEGER mUnit
82 INTEGER eMode
83
84 I = fileHandle
85
86 C-- Check that the fileHandle passed in is open
87 IF ( unitStatus(I,myThid) .NE. busyUnit ) GOTO 1000
88
89 unitStatus(I,myThid) = freeUnit
90 dUnit = dUnitNumber(I,myThid)
91 mUnit = mUnitNumber(I,myThid)
92 eMode = errorMode(I,myThid)
93 CLOSE(dUnit,ERR=999)
94 CLOSE(mUnit,ERR=999)
95
96 1000 CONTINUE
97 RETURN
98 999 CONTINUE
99 WRITE(msgBuf,'(A)') ' S/R DFILE_CLOSE'
100 CALL PRINT_ERROR( msgBuf , 1)
101 WRITE(msgBuf,'(A,A)') ' Thread ', myThid,' Close file failed'
102 CALL PRINT_ERROR( msgBuf , 1)
103 IF ( eMode .EQ. errorModeSTOP ) THEN
104 STOP 'ABNORMAL END: S/R DFILE_CLOSE'
105 ENDIF
106 ioErrorCount(myThid) = ioErrorCount(myThid)+1
107 GOTO 1000
108
109 END
110
111 SUBROUTINE DFILE_INIT
112 C /==========================================================\
113 C | SUBROUTINE DFILE_INIT |
114 C | o Model "dump" file initialisation procedure |
115 C |==========================================================|
116 C | Initalises data structures used by MITgcmUV "dump file" |
117 C | procedures. |
118 C | As coded this routine sets the unit number used for |
119 C | dump file IO. Two numbers are used one for data and one |
120 C | for meta data. It is possible to use more unit numbers |
121 C | and/or have different unit numbers per thread. This is |
122 C | not done here. |
123 C \==========================================================/
124 IMPLICIT NONE
125
126 C == Global variables ==
127 #include "SIZE.h"
128 #include "EEPARAMS.h"
129 #include "DFILE.h"
130
131 C == Local variables ==
132 C I, J - Loop counters
133 INTEGER I, J
134
135 DO j=1,MAX_NO_THREADS
136 DO i=1,ioUnitsPerThread
137 mUnitNumber(i,j) = 20+i*2-1
138 dUnitNumber(i,j) = 20+i*2
139 unitStatus (i,j) = freeUnit
140 metaDataStatus(i,j) = metaDataNotWritten
141 ENDDO
142 ENDDO
143
144 C-- Set initial access and error modes
145 CALL DFILE_SET_RW
146 CALL DFILE_SET_STOP_ON_ERROR
147
148 RETURN
149 END
150
151 SUBROUTINE DFILE_OPEN(
152 I fNam, fNamMeta, myThid,
153 O fileHandle)
154 C /==========================================================\
155 C | SUBROUTINE DFILE_OPEN |
156 C | o Open model "dump" file. |
157 C |==========================================================|
158 C | Controlling routine for doing actual I/O operations. |
159 C | Routine returns a handle to the caller that can be used |
160 C | in subsequent read and write operations. |
161 C \==========================================================/
162 IMPLICIT NONE
163
164 C == Global variables ==
165 #include "SIZE.h"
166 #include "EEPARAMS.h"
167 #include "EESUPPORT.h"
168 #include "DFILE.h"
169
170 INTEGER IFNBLNK
171 EXTERNAL IFNBLNK
172 INTEGER ILNBLNK
173 EXTERNAL ILNBLNK
174
175 C == Routine arguments ==
176 CHARACTER*(*) fNam
177 CHARACTER*(*) fNamMeta
178 INTEGER myThid
179 INTEGER fileHandle
180
181 C == Local variables ==
182 C msgBuf - Error message buffer
183 C dUnit - Unit number for data
184 C mUnit - Unit number for meta data
185 C eMode - Error mode
186 C aMode - Access mode
187 C I - Loop counters
188 INTEGER dUnit
189 INTEGER mUnit
190 INTEGER eMode
191 INTEGER aMode
192 CHARACTER*(MAX_LEN_MBUF) msgBuf
193 INTEGER I
194 INTEGER i1Lo, i1Hi, i2Lo, i2Hi
195
196 C-- Get statistics on names
197 i1Lo = IFNBLNK(fNam)
198 i1Hi = ILNBLNK(fNam)
199 i2Lo = IFNBLNK(fNamMeta)
200 i2Hi = ILNBLNK(fNamMeta)
201
202 C-- Choose a free I/O unit
203 fileHandle = -1
204 dUnit = 0
205 DO I=1, ioUnitsPerThread
206 IF ( unitStatus(I,myThid) .EQ. freeUnit ) THEN
207 dUnit = dUnitNumber(I,myThid)
208 mUnit = mUnitNumber(I,myThid)
209 unitStatus(I,myThid) = busyUnit
210 errorMode(I,myThid) = theErrorMode
211 accessMode(I,myThid) = theAccessMode
212 eMode = theErrorMode
213 aMode = theAccessMode
214 fileHandle = I
215 GOTO 10
216 ENDIF
217 ENDDO
218 10 CONTINUE
219 IF ( dUnit .EQ. 0 ) GOTO 999
220
221 C-- Remove previous meta information if there was any
222 metaDataStatus(fileHandle,myThid) = metaDataWritten
223 IF ( fNamMeta .NE. ' ' ) THEN
224 IF ( aMode .EQ. accessModeRW ) THEN
225 OPEN(UNIT=mUnit,FILE=fNamMeta(i2Lo:i2Hi),
226 & STATUS='UNKNOWN',ERR=899)
227 CLOSE(mUnit,ERR=899)
228 OPEN(UNIT=mUnit,FILE=fNamMeta(i2Lo:i2Hi),
229 & STATUS='UNKNOWN',ERR=899)
230 metaDataStatus(fileHandle,myThid) = metaDataNotWritten
231 nameOfMFile(fileHandle,myThid) = fNamMeta(i2Lo:i2Hi)
232 ENDIF
233 ENDIF
234
235 C-- Open data file
236 nameOfDFile(fileHandle,myThid) = fNam(i1Lo:i1Hi)
237 OPEN(UNIT=dUnit,FILE=fNam(i1Lo:i1Hi),STATUS='UNKNOWN', ERR=799,
238 & FORM='UNFORMATTED',ACCESS='SEQUENTIAL')
239
240
241 1000 CONTINUE
242 RETURN
243
244 999 CONTINUE
245 WRITE(msgBuf,'(A)') ' S/R DFILE_OPEN '
246 CALL PRINT_ERROR( msgBuf , 1)
247 WRITE(msgBuf,'(A,A)') ' Too many open files '
248 CALL PRINT_ERROR( msgBuf , 1)
249 WRITE(msgBuf,'(A,I4,A,A)') ' Thread ', myThid,' trying to open ',
250 & fNam(i1Lo:i1Hi)
251 CALL PRINT_ERROR( msgBuf , 1)
252 IF ( eMode .EQ. errorModeSTOP ) THEN
253 STOP 'ABNORMAL END: S/R DFILE_OPEN '
254 ENDIF
255 ioErrorCount(myThid) = ioErrorCount(myThid) + 1
256 GOTO 1000
257
258 899 CONTINUE
259 WRITE(msgBuf,'(A)') ' S/R DFILE_OPEN '
260 CALL PRINT_ERROR( msgBuf , 1)
261 WRITE(msgBuf,'(A,I4,A,A)') ' Thread ',myThid,' failed open for ',
262 & fNamMeta(i2Lo:i2Hi)
263 CALL PRINT_ERROR( msgBuf , 1)
264 IF ( eMode .EQ. errorModeSTOP ) THEN
265 STOP 'ABNORMAL END: S/R DFILE_OPEN '
266 ENDIF
267 ioErrorCount(myThid) = ioErrorCount(myThid) + 1
268 GOTO 1000
269
270 799 CONTINUE
271 WRITE(msgBuf,'(A)') ' S/R DFILE_OPEN '
272 CALL PRINT_ERROR( msgBuf , 1)
273 WRITE(msgBuf,'(A,I4,A,A)') ' Thread ',myThid,' failed open for ',
274 & fNam(i1Lo:i1Hi)
275 CALL PRINT_ERROR( msgBuf , 1)
276 IF ( eMode .EQ. errorModeSTOP ) THEN
277 STOP 'ABNORMAL END: S/R DFILE_OPEN '
278 ENDIF
279 ioErrorCount(myThid) = ioErrorCount(myThid) + 1
280 GOTO 1000
281
282 END
283
284 SUBROUTINE DFILE_READ_R4(
285 I lBuffer,
286 I fileHandle, myThid)
287 C /==========================================================\
288 C | SUBROUTINE DFILE_READ_R4 |
289 C | o Read record(s) from model dump file. |
290 C |==========================================================|
291 C | Controlling routine for doing actual I/O operations. |
292 C | Routine reads data from binary files formatted for |
293 C | model input. Could do elaborate reads from netCDF or |
294 C | using regular C I/O primitives. For now we use plain |
295 C | F77. |
296 C \==========================================================/
297 IMPLICIT NONE
298
299 C == Global variables ==
300 #include "SIZE.h"
301 #include "EEPARAMS.h"
302 #include "DFILE.h"
303
304 INTEGER IFNBLNK
305 EXTERNAL IFNBLNK
306 INTEGER ILNBLNK
307 EXTERNAL ILNBLNK
308
309 C == Routine arguments ==
310 C lBuffer - Length of buffer data will be read into
311 C fileHandle - Handle of already opened file
312 C myThid - Thread id calling this routine
313 INTEGER lBuffer
314 INTEGER fileHandle
315 INTEGER myThid
316
317 C == Local variables ==
318 C ioUnit - Unit number associated with fileHandle
319 C I - Loop counter
320 C eMode - fileHandles error mode
321 CHARACTER*(MAX_LEN_FNAM) fNam
322 CHARACTER*(MAX_LEN_MBUF) msgBuf
323 INTEGER ioUnit
324 INTEGER I, iLo, iHi
325 INTEGER eMode
326
327 C-- Get error mode
328 eMode = errorMode(fileHandle,myThid)
329
330 C-- Check that file is active
331 IF ( unitStatus(fileHandle,myThid) .NE. busyUnit ) GOTO 999
332
333 fNam = nameOfDFile(fileHandle,myThid)
334 iLo = IFNBLNK(fNam)
335 iHi = ILNBLNK(fNam)
336 ioUnit = dUnitNumber(fileHandle,myThid)
337 READ(ioUnit,ERR=899) (ioBuf_R4(I),I=1,lBuffer)
338
339
340 1000 CONTINUE
341 RETURN
342
343 999 CONTINUE
344 WRITE(msgBuf,'(A)') ' S/R DFILE_READ_R4 '
345 CALL PRINT_ERROR( msgBuf , 1)
346 WRITE(msgBuf,'(A,I4,A)') ' Thread ', myThid, ' unit not open '
347 CALL PRINT_ERROR( msgBuf , 1)
348 IF ( eMode .EQ. errorModeSTOP ) THEN
349 STOP 'ABNORMAL END: S/R DFILE_READ_R4'
350 ENDIF
351 ioErrorCount(myThid) = ioErrorCount(myThid) + 1
352 GOTO 1000
353
354 899 CONTINUE
355 WRITE(msgBuf,'(A)') ' S/R DFILE_READ_R4 '
356 CALL PRINT_ERROR( msgBuf , 1)
357 WRITE(msgBuf,'(A,I4,A)') ' Thread ', myThid,' error reading file'
358 CALL PRINT_ERROR( msgBuf , 1)
359 WRITE(msgBuf,'(A,A,A)') ' "', fNam(iLo:iHi),'"'
360 CALL PRINT_ERROR( msgBuf , 1)
361 IF ( eMode .EQ. errorModeSTOP ) THEN
362 STOP 'ABNORMAL END: S/R DFILE_READ_R4'
363 ENDIF
364 ioErrorCount(myThid) = ioErrorCount(myThid) + 1
365 GOTO 1000
366
367 END
368 SUBROUTINE DFILE_READ_R8(
369 I lBuffer,
370 I fileHandle, myThid)
371 C /==========================================================\
372 C | SUBROUTINE DFILE_READ_R8 |
373 C | o Read record(s) from model dump file. |
374 C |==========================================================|
375 C | Controlling routine for doing actual I/O operations. |
376 C | Routine reads data from binary files formatted for |
377 C | model input. Could do elaborate reads from netCDF or |
378 C | using regular C I/O primitives. For now we use plain |
379 C | F77. |
380 C \==========================================================/
381 IMPLICIT NONE
382
383 C == Global variables ==
384 #include "SIZE.h"
385 #include "EEPARAMS.h"
386 #include "DFILE.h"
387
388 INTEGER IFNBLNK
389 EXTERNAL IFNBLNK
390 INTEGER ILNBLNK
391 EXTERNAL ILNBLNK
392
393 C == Routine arguments ==
394 C lBuffer - Length of buffer data will be read into
395 C fileHandle - Handle of already opened file
396 C myThid - Thread id calling this routine
397 INTEGER lBuffer
398 INTEGER fileHandle
399 INTEGER myThid
400
401 C == Local variables ==
402 C ioUnit - Unit number associated with fileHandle
403 C I - Loop counter
404 C eMode - fileHandles error mode
405 CHARACTER*(MAX_LEN_FNAM) fNam
406 CHARACTER*(MAX_LEN_MBUF) msgBuf
407 INTEGER ioUnit
408 INTEGER I, iLo, iHi
409 INTEGER eMode
410
411 C-- Get error mode
412 eMode = errorMode(fileHandle,myThid)
413
414 C-- Check that file is active
415 IF ( unitStatus(fileHandle,myThid) .NE. busyUnit ) GOTO 999
416
417 fNam = nameOfDFile(fileHandle,myThid)
418 iLo = IFNBLNK(fNam)
419 iHi = ILNBLNK(fNam)
420 ioUnit = dUnitNumber(fileHandle,myThid)
421 READ(ioUnit,ERR=899) (ioBuf_R8(I),I=1,lBuffer)
422
423
424 1000 CONTINUE
425 RETURN
426
427 999 CONTINUE
428 WRITE(msgBuf,'(A)') ' S/R DFILE_READ_R8 '
429 CALL PRINT_ERROR( msgBuf , 1)
430 WRITE(msgBuf,'(A,I4,A)') ' Thread ', myThid, ' unit not open '
431 CALL PRINT_ERROR( msgBuf , 1)
432 IF ( eMode .EQ. errorModeSTOP ) THEN
433 STOP 'ABNORMAL END: S/R DFILE_READ_R8'
434 ENDIF
435 ioErrorCount(myThid) = ioErrorCount(myThid) + 1
436 GOTO 1000
437
438 899 CONTINUE
439 WRITE(msgBuf,'(A)') ' S/R DFILE_READ_R8 '
440 CALL PRINT_ERROR( msgBuf , 1)
441 WRITE(msgBuf,'(A,I4,A)') ' Thread ', myThid,' error reading file'
442 CALL PRINT_ERROR( msgBuf , 1)
443 WRITE(msgBuf,'(A,A,A)') ' "', fNam(iLo:iHi),'"'
444 CALL PRINT_ERROR( msgBuf , 1)
445 IF ( eMode .EQ. errorModeSTOP ) THEN
446 STOP 'ABNORMAL END: S/R DFILE_READ_R8'
447 ENDIF
448 ioErrorCount(myThid) = ioErrorCount(myThid) + 1
449 GOTO 1000
450
451 END
452
453 SUBROUTINE DFILE_SET_RO
454 C /==========================================================\
455 C | SUBROUTINE DFILE_SET_RO |
456 C | o Sets new connections to be read-only. |
457 C \==========================================================/
458 IMPLICIT NONE
459
460 C == Global variables ==
461 #include "SIZE.h"
462 #include "EEPARAMS.h"
463 #include "DFILE.h"
464
465 theAccessMode = accessModeRO
466
467 RETURN
468 END
469
470 SUBROUTINE DFILE_SET_RW
471 C /==========================================================\
472 C | SUBROUTINE DFILE_SET_RW |
473 C | o Sets new connections to be read-write |
474 C \==========================================================/
475 IMPLICIT NONE
476
477 C == Global variables ==
478 #include "SIZE.h"
479 #include "EEPARAMS.h"
480 #include "DFILE.h"
481
482 theAccessMode = accessModeRW
483
484 RETURN
485 END
486
487 SUBROUTINE DFILE_SET_STOP_ON_ERROR
488 C /==========================================================\
489 C | SUBROUTINE DFILE_SET_STOP_ON_ERROR |
490 C | o Sets new connections to STOP on error |
491 C \==========================================================/
492 IMPLICIT NONE
493
494 C == Global variables ==
495 #include "SIZE.h"
496 #include "EEPARAMS.h"
497 #include "DFILE.h"
498
499 theErrorMode = errorModeSTOP
500
501 RETURN
502 END
503
504 SUBROUTINE DFILE_SET_CONT_ON_ERROR
505 C /==========================================================\
506 C | SUBROUTINE DFILE_SET_CONT_ON_ERROR |
507 C | o Sets new connections to continue on error |
508 C \==========================================================/
509 IMPLICIT NONE
510
511 C == Global variables ==
512 #include "SIZE.h"
513 #include "EEPARAMS.h"
514 #include "DFILE.h"
515
516 theErrorMode = errorModeCONT
517
518 RETURN
519 END
520
521 SUBROUTINE DFILE_WRITE_R4(
522 I lBuffer,
523 I nDims, dimList,
524 I fileHandle, fileId, myThid )
525 C /==========================================================\
526 C | SUBROUTINE DFILE_WRITE_R4 |
527 C | o Write record(s) to model dump file. |
528 C |==========================================================|
529 C | Controlling routine for doing actual I/O operations. |
530 C | Routine writes data to binary files. |
531 C | Could do elaborate write to netCDF or |
532 C | use C I/O primitives. For now we use plain F77 but the |
533 C | routine does write both data and metadata. Metadata is |
534 C | extra info. which describes the data - in this case it |
535 C | is information indicating the subregion of the global |
536 C | dataset being written out. |
537 C \==========================================================/
538 IMPLICIT NONE
539
540 C == Global variables ==
541 #include "SIZE.h"
542 #include "EEPARAMS.h"
543 #include "DFILE.h"
544
545 C == Routine arguments ==
546 C lBuffer - Amount of data written
547 C nDims - Global and subset dimensionality
548 C dimList - List of global and subset extents
549 C fileHandle - Handle identifying actual IO unit
550 C myThid - Thread number of thread calling this
551 C routine
552 C eMode - error mode for this fileHandle
553 INTEGER lBuffer
554 INTEGER nDims
555 INTEGER dimList(nDims*3)
556 INTEGER fileHandle
557 INTEGER fileId
558 INTEGER myThid
559
560 C == Local variables ==
561 C ioUnit - Unit number for I/O
562 C msgBuf - Textual printing message buffer
563 C eMode - Error mode for this file handle
564 INTEGER ioUnit
565 CHARACTER*(MAX_LEN_MBUF) msgBuf
566 CHARACTER*(MAX_LEN_FNAM) fNam
567 INTEGER eMode
568 INTEGER I
569
570 C-- Set error mode
571 eMode = errorMode(fileHandle,myThid)
572
573 C-- Check that file is active
574 IF ( unitStatus(fileHandle,myThid) .NE. busyUnit ) GOTO 999
575
576 C-- Write data
577 ioUnit = dUnitNumber(fileHandle,myThid)
578 fNam = nameOfDFile(fileHandle,myThid)
579 WRITE(ioUnit,ERR=899) (ioBuf_R4(I),I=1,lBuffer)
580
581 C-- Now write meta information
582 IF ( metaDataStatus(fileHandle,myThid) .EQ.
583 & metaDataNotWritten ) THEN
584 ioUnit = mUnitNumber(fileHandle,myThid)
585
586 WRITE(msgBuf,'(A)') '// START OF META DATA'
587 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
588
589 WRITE(msgBuf,'(A,A)') ' id =[ ','/* Identifier */'
590 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
591 CALL PRINT_LIST_I( fileId, 1, INDEX_NONE, .FALSE., .TRUE.,
592 & ioUnit )
593 WRITE(msgBuf,'(A)') ' ]; '
594 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
595
596 WRITE(msgBuf,'(A,A)') ' nDims =[ ','/* Number of dimensions */'
597 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
598 CALL PRINT_LIST_I( nDims, 1, INDEX_NONE, .FALSE., .TRUE.,
599 & ioUnit )
600 WRITE(msgBuf,'(A)') ' ]; '
601 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
602
603 WRITE(msgBuf,'(A,A)') ' dimList =[ ',
604 & '/* Global1, local min1, local max1, ... */'
605 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
606 DO I=1,nDims
607 CALL PRINT_LIST_I( dimList((I-1)*3+1), 3, INDEX_NONE,
608 & I.NE.nDims, .FALSE., ioUnit )
609 ENDDO
610 WRITE(msgBuf,'(A)') ' ]; '
611 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
612
613 WRITE(msgBuf,'(A,A)') ' format =[ ','/* Field format */'
614 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
615 WRITE(msgBuf,'(16X,A)') '''float32'''
616 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
617 WRITE(msgBuf,'(A)') ' ]; '
618 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
619
620 WRITE(msgBuf,'(A)') '// END OF META DATA'
621 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
622 metaDataStatus(fileHandle,myThid) = metaDataWritten
623 ENDIF
624
625 1000 CONTINUE
626 RETURN
627
628 999 CONTINUE
629 WRITE(msgBuf,'(A)') ' S/R DFILE_WRITE_R4 '
630 CALL PRINT_ERROR( msgBuf , 1)
631 WRITE(msgBuf,'(A,A)') ' Thread ', myThid, ' unit not open '
632 CALL PRINT_ERROR( msgBuf , 1)
633 IF ( eMode .EQ. errorModeSTOP ) THEN
634 STOP 'ABNORMAL END: S/R DFILE_WRITE_R4'
635 ENDIF
636 ioErrorCount(myThid) = ioErrorCount(myThid) + 1
637 GOTO 1000
638
639 899 CONTINUE
640 WRITE(msgBuf,'(A)') ' S/R DFILE_WRITE_R4 '
641 CALL PRINT_ERROR( msgBuf , 1)
642 WRITE(msgBuf,'(A,A)') ' Thread ', myThid, ' write error '
643 CALL PRINT_ERROR( msgBuf , 1)
644 WRITE(msgBuf,'(A,A)') ' File ', fNam
645 CALL PRINT_ERROR( msgBuf , 1)
646 IF ( eMode .EQ. errorModeSTOP ) THEN
647 STOP 'ABNORMAL END: S/R DFILE_WRITE_R4'
648 ENDIF
649 ioErrorCount(myThid) = ioErrorCount(myThid) + 1
650 GOTO 1000
651
652 END
653
654 SUBROUTINE DFILE_WRITE_R8(
655 I lBuffer,
656 I nDims, dimList,
657 I fileHandle, fileId, myThid )
658 C /==========================================================\
659 C | SUBROUTINE DFILE_WRITE_R8 |
660 C | o Write record(s) to model dump file. |
661 C |==========================================================|
662 C | Controlling routine for doing actual I/O operations. |
663 C | Routine writes data to binary files. |
664 C | Could do elaborate write to netCDF or |
665 C | use C I/O primitives. For now we use plain F77 but the |
666 C | routine does write both data and metadata. Metadata is |
667 C | extra info. which describes the data - in this case it |
668 C | is information indicating the subregion of the global |
669 C | dataset being written out. |
670 C \==========================================================/
671 IMPLICIT NONE
672
673 C == Global variables ==
674 #include "SIZE.h"
675 #include "EEPARAMS.h"
676 #include "DFILE.h"
677
678 C == Routine arguments ==
679 C buffer - Subset data to write
680 C lBuffer - Amount of data written
681 C nDims - Global and subset dimensionality
682 C dimList - List of global and subset extents
683 C fileHandle - Handle identifying actual IO unit
684 C myThid - Thread number of thread calling this
685 C routine
686 C eMode - error mode for this fileHandle
687 INTEGER lBuffer
688 INTEGER nDims
689 INTEGER dimList(nDims*3)
690 INTEGER fileHandle
691 INTEGER fileId
692 INTEGER myThid
693
694 C == Local variables ==
695 C ioUnit - Unit number for I/O
696 C msgBuf - Textual printing message buffer
697 C eMode - Error mode for this file handle
698 INTEGER ioUnit
699 CHARACTER*(MAX_LEN_MBUF) msgBuf
700 CHARACTER*(MAX_LEN_FNAM) fNam
701 INTEGER eMode
702 INTEGER I
703
704 C-- Set error mode
705 eMode = errorMode(fileHandle,myThid)
706
707 C-- Check that file is active
708 IF ( unitStatus(fileHandle,myThid) .NE. busyUnit ) GOTO 999
709
710 C-- Write data
711 ioUnit = dUnitNumber(fileHandle,myThid)
712 fNam = nameOfDFile(fileHandle,myThid)
713 WRITE(ioUnit,ERR=899) (ioBuf_R8(I),I=1,lBuffer)
714
715 C-- Now write meta information
716 IF ( metaDataStatus(fileHandle,myThid) .EQ.
717 & metaDataNotWritten ) THEN
718 ioUnit = mUnitNumber(fileHandle,myThid)
719
720 WRITE(msgBuf,'(A)') '// START OF META DATA'
721 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
722
723 WRITE(msgBuf,'(A,A)') ' id =[ ','/* Identifier */'
724 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
725 CALL PRINT_LIST_I( fileId, 1, INDEX_NONE, .FALSE., .TRUE.,
726 & ioUnit )
727 WRITE(msgBuf,'(A)') ' ]; '
728 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
729
730 WRITE(msgBuf,'(A,A)') ' nDims =[ ','/* Number of dimensions */'
731 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
732 CALL PRINT_LIST_I( nDims, 1, INDEX_NONE, .FALSE., .TRUE.,
733 & ioUnit )
734 WRITE(msgBuf,'(A)') ' ]; '
735 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
736
737 WRITE(msgBuf,'(A,A)') ' dimList =[ ',
738 & '/* Global1, local min1, local max1, ... */'
739 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
740 DO I=1,nDims
741 CALL PRINT_LIST_I( dimList((I-1)*3+1), 3, INDEX_NONE,
742 & I.NE.nDims, .FALSE., ioUnit )
743 ENDDO
744 WRITE(msgBuf,'(A)') ' ]; '
745 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
746
747 WRITE(msgBuf,'(A,A)') ' format =[ ','/* Field format */'
748 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
749 WRITE(msgBuf,'(16X,A)') '''float64'''
750 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
751 WRITE(msgBuf,'(A)') ' ]; '
752 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
753
754 WRITE(msgBuf,'(A)') '// END OF META DATA'
755 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
756 metaDataStatus(fileHandle,myThid) = metaDataWritten
757 ENDIF
758
759 1000 CONTINUE
760 RETURN
761
762 999 CONTINUE
763 WRITE(msgBuf,'(A)') ' S/R DFILE_WRITE_R8 '
764 CALL PRINT_ERROR( msgBuf , 1)
765 WRITE(msgBuf,'(A,A)') ' Thread ', myThid, ' unit not open '
766 CALL PRINT_ERROR( msgBuf , 1)
767 IF ( eMode .EQ. errorModeSTOP ) THEN
768 STOP 'ABNORMAL END: S/R DFILE_WRITE_R8'
769 ENDIF
770 ioErrorCount(myThid) = ioErrorCount(myThid) + 1
771 GOTO 1000
772
773 899 CONTINUE
774 WRITE(msgBuf,'(A)') ' S/R DFILE_WRITE_R8 '
775 CALL PRINT_ERROR( msgBuf , 1)
776 WRITE(msgBuf,'(A,A)') ' Thread ', myThid, ' write error '
777 CALL PRINT_ERROR( msgBuf , 1)
778 WRITE(msgBuf,'(A,A)') ' File ', fNam
779 CALL PRINT_ERROR( msgBuf , 1)
780 IF ( eMode .EQ. errorModeSTOP ) THEN
781 STOP 'ABNORMAL END: S/R DFILE_WRITE_R8'
782 ENDIF
783 ioErrorCount(myThid) = ioErrorCount(myThid) + 1
784 GOTO 1000
785
786 #endif /* USE_DFILE */
787
788 END
  ViewVC Help
Powered by ViewVC 1.1.22