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