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

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

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

Revision 1.11 - (hide annotations) (download)
Sun Feb 4 14:38:42 2001 UTC (23 years, 5 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 cnh 1.11 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 cnh 1.1
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 cnh 1.8 C file systems. Other systems do not support the OPEN(...='READ_ONLY')
43 cnh 1.1 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 adcroft 1.9 IMPLICIT NONE
59 cnh 1.1
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 adcroft 1.10 #ifdef USE_DFILE
71    
72 cnh 1.1 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 adcroft 1.9 IMPLICIT NONE
125 cnh 1.1
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 adcroft 1.9 IMPLICIT NONE
163 cnh 1.1
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 adcroft 1.9 OPEN(UNIT=mUnit,FILE=fNamMeta(i2Lo:i2Hi),
226 cnh 1.8 & STATUS='UNKNOWN',ERR=899)
227 cnh 1.1 CLOSE(mUnit,ERR=899)
228 adcroft 1.9 OPEN(UNIT=mUnit,FILE=fNamMeta(i2Lo:i2Hi),
229 cnh 1.8 & STATUS='UNKNOWN',ERR=899)
230 cnh 1.6 metaDataStatus(fileHandle,myThid) = metaDataNotWritten
231     nameOfMFile(fileHandle,myThid) = fNamMeta(i2Lo:i2Hi)
232 cnh 1.1 ENDIF
233     ENDIF
234    
235     C-- Open data file
236     nameOfDFile(fileHandle,myThid) = fNam(i1Lo:i1Hi)
237 adcroft 1.9 OPEN(UNIT=dUnit,FILE=fNam(i1Lo:i1Hi),STATUS='UNKNOWN', ERR=799,
238 cnh 1.1 & 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 cnh 1.8 WRITE(msgBuf,'(A,I4,A,A)') ' Thread ', myThid,' trying to open ',
250 cnh 1.1 & 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 cnh 1.8 WRITE(msgBuf,'(A,I4,A,A)') ' Thread ',myThid,' failed open for ',
262 cnh 1.1 & 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 cnh 1.8 WRITE(msgBuf,'(A,I4,A,A)') ' Thread ',myThid,' failed open for ',
274 cnh 1.1 & 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 adcroft 1.9 IMPLICIT NONE
298 cnh 1.1
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 adcroft 1.5 READ(ioUnit,ERR=899) (ioBuf_R4(I),I=1,lBuffer)
338 cnh 1.1
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 cnh 1.8 WRITE(msgBuf,'(A,I4,A)') ' Thread ', myThid,' error reading file'
358 cnh 1.3 CALL PRINT_ERROR( msgBuf , 1)
359     WRITE(msgBuf,'(A,A,A)') ' "', fNam(iLo:iHi),'"'
360 cnh 1.1 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 adcroft 1.9 IMPLICIT NONE
382 cnh 1.1
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 cnh 1.8 WRITE(msgBuf,'(A,I4,A)') ' Thread ', myThid,' error reading file'
442 cnh 1.3 CALL PRINT_ERROR( msgBuf , 1)
443     WRITE(msgBuf,'(A,A,A)') ' "', fNam(iLo:iHi),'"'
444 cnh 1.1 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 adcroft 1.9 IMPLICIT NONE
459 cnh 1.1
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 adcroft 1.9 IMPLICIT NONE
476 cnh 1.1
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 adcroft 1.9 IMPLICIT NONE
493 cnh 1.1
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 adcroft 1.9 IMPLICIT NONE
510 cnh 1.1
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 adcroft 1.9 IMPLICIT NONE
539 cnh 1.1
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 cnh 1.2 CHARACTER*(MAX_LEN_MBUF) msgBuf
566     CHARACTER*(MAX_LEN_FNAM) fNam
567 cnh 1.1 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 cnh 1.8 IF ( metaDataStatus(fileHandle,myThid) .EQ.
583     & metaDataNotWritten ) THEN
584 cnh 1.1 ioUnit = mUnitNumber(fileHandle,myThid)
585    
586     WRITE(msgBuf,'(A)') '// START OF META DATA'
587     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
588    
589 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' id =[ ','/* Identifier */'
590 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
591 cnh 1.8 CALL PRINT_LIST_I( fileId, 1, INDEX_NONE, .FALSE., .TRUE.,
592     & ioUnit )
593 adcroft 1.5 WRITE(msgBuf,'(A)') ' ]; '
594 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
595    
596 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' nDims =[ ','/* Number of dimensions */'
597 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
598 cnh 1.8 CALL PRINT_LIST_I( nDims, 1, INDEX_NONE, .FALSE., .TRUE.,
599     & ioUnit )
600 adcroft 1.5 WRITE(msgBuf,'(A)') ' ]; '
601 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
602    
603 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' dimList =[ ',
604 cnh 1.1 & '/* Global1, local min1, local max1, ... */'
605     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
606     DO I=1,nDims
607 cnh 1.8 CALL PRINT_LIST_I( dimList((I-1)*3+1), 3, INDEX_NONE,
608     & I.NE.nDims, .FALSE., ioUnit )
609 cnh 1.1 ENDDO
610 adcroft 1.5 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 cnh 1.1 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 adcroft 1.9 IMPLICIT NONE
672 cnh 1.1
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 cnh 1.2 CHARACTER*(MAX_LEN_MBUF) msgBuf
700     CHARACTER*(MAX_LEN_FNAM) fNam
701 cnh 1.1 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 cnh 1.8 IF ( metaDataStatus(fileHandle,myThid) .EQ.
717     & metaDataNotWritten ) THEN
718 cnh 1.1 ioUnit = mUnitNumber(fileHandle,myThid)
719    
720     WRITE(msgBuf,'(A)') '// START OF META DATA'
721     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
722    
723 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' id =[ ','/* Identifier */'
724 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
725 cnh 1.8 CALL PRINT_LIST_I( fileId, 1, INDEX_NONE, .FALSE., .TRUE.,
726     & ioUnit )
727 adcroft 1.5 WRITE(msgBuf,'(A)') ' ]; '
728 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
729    
730 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' nDims =[ ','/* Number of dimensions */'
731 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
732 cnh 1.8 CALL PRINT_LIST_I( nDims, 1, INDEX_NONE, .FALSE., .TRUE.,
733     & ioUnit )
734 adcroft 1.5 WRITE(msgBuf,'(A)') ' ]; '
735 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
736    
737 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' dimList =[ ',
738 cnh 1.1 & '/* Global1, local min1, local max1, ... */'
739     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
740     DO I=1,nDims
741 cnh 1.8 CALL PRINT_LIST_I( dimList((I-1)*3+1), 3, INDEX_NONE,
742     & I.NE.nDims, .FALSE., ioUnit )
743 cnh 1.1 ENDDO
744 adcroft 1.5 WRITE(msgBuf,'(A)') ' ]; '
745 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
746 adcroft 1.5
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 cnh 1.1 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 adcroft 1.10
786     #endif /* USE_DFILE */
787 cnh 1.1
788     END
  ViewVC Help
Powered by ViewVC 1.1.22