/[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.11 - (show annotations) (download)
Sun Feb 4 14:38:42 2001 UTC (23 years, 2 months ago) by cnh
Branch: MAIN
CVS Tags: checkpoint46n_post, checkpoint51k_post, checkpoint47e_post, checkpoint52l_pre, ecco_c44_e19, hrcube4, hrcube5, checkpoint46l_post, checkpoint46g_pre, checkpoint47c_post, release1_p13_pre, checkpoint50c_post, checkpoint46f_post, checkpoint52d_pre, checkpoint48e_post, checkpoint50g_post, checkpoint46b_post, checkpoint52j_pre, checkpoint43a-release1mods, checkpoint51o_pre, checkpoint44g_post, checkpoint48c_post, ecco_c50_e32, ecco_c50_e33, ecco_c50_e30, ecco_c50_e31, release1_p13, checkpoint40pre3, checkpoint40pre2, checkpoint40pre1, checkpoint51l_post, checkpoint40pre7, checkpoint40pre6, checkpoint48i_post, checkpoint40pre9, checkpoint40pre8, checkpoint46l_pre, checkpoint50d_pre, checkpoint52k_post, chkpt44d_post, checkpoint51, checkpoint52, release1_p8, release1_p9, checkpoint50d_post, release1_p1, release1_p2, release1_p3, release1_p4, release1_p5, release1_p6, release1_p7, checkpoint52f_post, checkpoint50b_pre, checkpoint44e_pre, checkpoint51f_post, release1_b1, checkpoint48b_post, ecco_c51_e34d, ecco_c51_e34e, ecco_c51_e34f, ecco_c51_e34g, ecco_c51_e34a, ecco_c51_e34b, ecco_c51_e34c, checkpoint43, checkpoint51d_post, checkpoint48c_pre, checkpoint51t_post, checkpoint38, checkpoint51n_post, release1_chkpt44d_post, checkpoint52i_pre, hrcube_2, hrcube_3, checkpoint51s_post, checkpoint48d_pre, checkpoint51j_post, checkpoint47i_post, checkpoint52e_pre, checkpoint52e_post, checkpoint51n_pre, checkpoint47d_post, icebear5, icebear4, icebear3, icebear2, checkpoint46d_pre, checkpoint48d_post, release1-branch_tutorials, checkpoint48f_post, checkpoint45d_post, checkpoint52b_pre, checkpoint46j_pre, ecco_c50_e28, checkpoint51l_pre, checkpoint47d_pre, chkpt44a_post, checkpoint44h_pre, checkpoint48h_post, checkpoint51q_post, checkpoint40pre4, ecco_c50_e29, checkpoint51b_pre, checkpoint46a_post, checkpoint47g_post, checkpoint52b_post, checkpoint52c_post, checkpoint46j_post, checkpoint51h_pre, checkpoint46k_post, checkpoint46b_pre, chkpt44c_pre, checkpoint52h_pre, checkpoint45a_post, checkpoint50f_post, checkpoint50a_post, checkpoint50f_pre, hrcube_1, checkpoint51m_post, checkpoint44e_post, ecco_c44_e18, ecco_c44_e17, ecco_c44_e16, release1_p12, release1_p10, release1_p11, release1_p16, release1_p17, release1_p14, release1_p15, pre38tag1, checkpoint47a_post, ecco_c50_e33a, branchpoint-genmake2, checkpoint46e_pre, checkpoint51r_post, checkpoint45b_post, checkpoint51i_post, release1-branch-end, c37_adj, release1_final_v1, checkpoint51b_post, release1_p12_pre, checkpoint46c_pre, checkpoint44f_post, checkpoint47b_post, checkpoint44b_post, ecco_c51_e34, checkpoint46h_pre, checkpoint52d_post, checkpoint46m_post, checkpoint46a_pre, checkpoint50c_pre, checkpoint45c_post, ecco_ice2, ecco_ice1, checkpoint44h_post, pre38-close, checkpoint46g_post, checkpoint51c_post, checkpoint39, checkpoint52a_pre, checkpoint37, checkpoint36, checkpoint35, checkpoint46i_post, checkpoint50h_post, checkpoint52i_post, checkpoint50e_pre, checkpoint50i_post, ecco_c44_e25, checkpoint51i_pre, checkpoint48a_post, checkpoint47j_post, branch-exfmods-tag, checkpoint40pre5, checkpoint52j_post, checkpoint47f_post, checkpoint50e_post, chkpt44a_pre, ecco_c44_e22, ecco_c44_e23, ecco_c44_e20, ecco_c44_e21, ecco_c44_e26, ecco_c44_e27, ecco_c44_e24, checkpoint46c_post, ecco-branch-mod1, ecco-branch-mod2, ecco-branch-mod3, ecco-branch-mod4, ecco-branch-mod5, branch-netcdf, checkpoint52l_post, checkpoint46e_post, release1_beta1, checkpoint51e_post, checkpoint44b_pre, checkpoint42, checkpoint40, checkpoint41, checkpoint46, checkpoint47, checkpoint44, checkpoint45, checkpoint48, checkpoint49, checkpoint46h_post, checkpoint51o_post, checkpoint50, checkpoint51f_pre, chkpt44c_post, checkpoint47h_post, checkpoint52a_post, checkpoint44f_pre, checkpoint51g_post, ecco_c52_e35, checkpoint46d_post, checkpoint50b_post, release1-branch_branchpoint, checkpoint52f_pre, checkpoint51a_post, checkpoint51p_post, checkpoint48g_post, checkpoint51u_post
Branch point for: c24_e25_ice, branch-exfmods-curt, release1_coupled, release1_final, release1-branch, branch-genmake2, release1, branch-nonh, tg2-branch, ecco-branch, release1_50yr, netcdf-sm0, icebear, checkpoint51n_branch, pre38
Changes since 1.10: +2 -1 lines 
Made sure each .F and .h file had
the CVS keywords Header and Name at its start.
Most had header but very few currently have Name, so
lots of changes!
1 C $Header: /u/gcmpack/models/MITgcmUV/eesupp/src/dfile.F,v 1.10 2000/03/15 16:00:52 adcroft 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