/[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.8 - (hide annotations) (download)
Wed Oct 28 03:11:33 1998 UTC (25 years, 8 months ago) by cnh
Branch: MAIN
CVS Tags: checkpoint17, checkpoint19, checkpoint18, checkpoint20, checkpoint21, checkpoint22, checkpoint16
Changes since 1.7: +27 -17 lines 
Changes to support
 - g77 compilation under Linux
 - LR(1) form of 64-bit is D or E for constants
 - Modified adjoint of exch with adjoint variables
   acuumulated.
1 cnh 1.8 C $Header: /u/gcmpack/models/MITgcmUV/eesupp/src/dfile.F,v 1.7 1998/06/30 12:25:14 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 cnh 1.8 C file systems. Other systems do not support the OPEN(...='READ_ONLY')
42 cnh 1.1 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 cnh 1.8 OPEN(UNIT=mUnit,NAME=fNamMeta(i2Lo:i2Hi),
220     & STATUS='UNKNOWN',ERR=899)
221 cnh 1.1 CLOSE(mUnit,ERR=899)
222 cnh 1.8 OPEN(UNIT=mUnit,NAME=fNamMeta(i2Lo:i2Hi),
223     & STATUS='UNKNOWN',ERR=899)
224 cnh 1.6 metaDataStatus(fileHandle,myThid) = metaDataNotWritten
225     nameOfMFile(fileHandle,myThid) = fNamMeta(i2Lo:i2Hi)
226 cnh 1.1 ENDIF
227     ENDIF
228    
229     C-- Open data file
230     nameOfDFile(fileHandle,myThid) = fNam(i1Lo:i1Hi)
231 cnh 1.7 OPEN(UNIT=dUnit,NAME=fNam(i1Lo:i1Hi),STATUS='UNKNOWN', ERR=799,
232 cnh 1.1 & FORM='UNFORMATTED',ACCESS='SEQUENTIAL')
233    
234    
235     1000 CONTINUE
236     RETURN
237    
238     999 CONTINUE
239     WRITE(msgBuf,'(A)') ' S/R DFILE_OPEN '
240     CALL PRINT_ERROR( msgBuf , 1)
241     WRITE(msgBuf,'(A,A)') ' Too many open files '
242     CALL PRINT_ERROR( msgBuf , 1)
243 cnh 1.8 WRITE(msgBuf,'(A,I4,A,A)') ' Thread ', myThid,' trying to open ',
244 cnh 1.1 & fNam(i1Lo:i1Hi)
245     CALL PRINT_ERROR( msgBuf , 1)
246     IF ( eMode .EQ. errorModeSTOP ) THEN
247     STOP 'ABNORMAL END: S/R DFILE_OPEN '
248     ENDIF
249     ioErrorCount(myThid) = ioErrorCount(myThid) + 1
250     GOTO 1000
251    
252     899 CONTINUE
253     WRITE(msgBuf,'(A)') ' S/R DFILE_OPEN '
254     CALL PRINT_ERROR( msgBuf , 1)
255 cnh 1.8 WRITE(msgBuf,'(A,I4,A,A)') ' Thread ',myThid,' failed open for ',
256 cnh 1.1 & fNamMeta(i2Lo:i2Hi)
257     CALL PRINT_ERROR( msgBuf , 1)
258     IF ( eMode .EQ. errorModeSTOP ) THEN
259     STOP 'ABNORMAL END: S/R DFILE_OPEN '
260     ENDIF
261     ioErrorCount(myThid) = ioErrorCount(myThid) + 1
262     GOTO 1000
263    
264     799 CONTINUE
265     WRITE(msgBuf,'(A)') ' S/R DFILE_OPEN '
266     CALL PRINT_ERROR( msgBuf , 1)
267 cnh 1.8 WRITE(msgBuf,'(A,I4,A,A)') ' Thread ',myThid,' failed open for ',
268 cnh 1.1 & fNam(i1Lo:i1Hi)
269     CALL PRINT_ERROR( msgBuf , 1)
270     IF ( eMode .EQ. errorModeSTOP ) THEN
271     STOP 'ABNORMAL END: S/R DFILE_OPEN '
272     ENDIF
273     ioErrorCount(myThid) = ioErrorCount(myThid) + 1
274     GOTO 1000
275    
276     END
277    
278     SUBROUTINE DFILE_READ_R4(
279     I lBuffer,
280     I fileHandle, myThid)
281     C /==========================================================\
282     C | SUBROUTINE DFILE_READ_R4 |
283     C | o Read record(s) from model dump file. |
284     C |==========================================================|
285     C | Controlling routine for doing actual I/O operations. |
286     C | Routine reads data from binary files formatted for |
287     C | model input. Could do elaborate reads from netCDF or |
288     C | using regular C I/O primitives. For now we use plain |
289     C | F77. |
290     C \==========================================================/
291    
292     C == Global variables ==
293     #include "SIZE.h"
294     #include "EEPARAMS.h"
295     #include "DFILE.h"
296    
297     INTEGER IFNBLNK
298     EXTERNAL IFNBLNK
299     INTEGER ILNBLNK
300     EXTERNAL ILNBLNK
301    
302     C == Routine arguments ==
303     C lBuffer - Length of buffer data will be read into
304     C fileHandle - Handle of already opened file
305     C myThid - Thread id calling this routine
306     INTEGER lBuffer
307     INTEGER fileHandle
308     INTEGER myThid
309    
310     C == Local variables ==
311     C ioUnit - Unit number associated with fileHandle
312     C I - Loop counter
313     C eMode - fileHandles error mode
314     CHARACTER*(MAX_LEN_FNAM) fNam
315     CHARACTER*(MAX_LEN_MBUF) msgBuf
316     INTEGER ioUnit
317     INTEGER I, iLo, iHi
318     INTEGER eMode
319    
320     C-- Get error mode
321     eMode = errorMode(fileHandle,myThid)
322    
323     C-- Check that file is active
324     IF ( unitStatus(fileHandle,myThid) .NE. busyUnit ) GOTO 999
325    
326     fNam = nameOfDFile(fileHandle,myThid)
327     iLo = IFNBLNK(fNam)
328     iHi = ILNBLNK(fNam)
329     ioUnit = dUnitNumber(fileHandle,myThid)
330 adcroft 1.5 READ(ioUnit,ERR=899) (ioBuf_R4(I),I=1,lBuffer)
331 cnh 1.1
332    
333     1000 CONTINUE
334     RETURN
335    
336     999 CONTINUE
337     WRITE(msgBuf,'(A)') ' S/R DFILE_READ_R4 '
338     CALL PRINT_ERROR( msgBuf , 1)
339     WRITE(msgBuf,'(A,I4,A)') ' Thread ', myThid, ' unit not open '
340     CALL PRINT_ERROR( msgBuf , 1)
341     IF ( eMode .EQ. errorModeSTOP ) THEN
342     STOP 'ABNORMAL END: S/R DFILE_READ_R4'
343     ENDIF
344     ioErrorCount(myThid) = ioErrorCount(myThid) + 1
345     GOTO 1000
346    
347     899 CONTINUE
348     WRITE(msgBuf,'(A)') ' S/R DFILE_READ_R4 '
349     CALL PRINT_ERROR( msgBuf , 1)
350 cnh 1.8 WRITE(msgBuf,'(A,I4,A)') ' Thread ', myThid,' error reading file'
351 cnh 1.3 CALL PRINT_ERROR( msgBuf , 1)
352     WRITE(msgBuf,'(A,A,A)') ' "', fNam(iLo:iHi),'"'
353 cnh 1.1 CALL PRINT_ERROR( msgBuf , 1)
354     IF ( eMode .EQ. errorModeSTOP ) THEN
355     STOP 'ABNORMAL END: S/R DFILE_READ_R4'
356     ENDIF
357     ioErrorCount(myThid) = ioErrorCount(myThid) + 1
358     GOTO 1000
359    
360     END
361     SUBROUTINE DFILE_READ_R8(
362     I lBuffer,
363     I fileHandle, myThid)
364     C /==========================================================\
365     C | SUBROUTINE DFILE_READ_R8 |
366     C | o Read record(s) from model dump file. |
367     C |==========================================================|
368     C | Controlling routine for doing actual I/O operations. |
369     C | Routine reads data from binary files formatted for |
370     C | model input. Could do elaborate reads from netCDF or |
371     C | using regular C I/O primitives. For now we use plain |
372     C | F77. |
373     C \==========================================================/
374    
375     C == Global variables ==
376     #include "SIZE.h"
377     #include "EEPARAMS.h"
378     #include "DFILE.h"
379    
380     INTEGER IFNBLNK
381     EXTERNAL IFNBLNK
382     INTEGER ILNBLNK
383     EXTERNAL ILNBLNK
384    
385     C == Routine arguments ==
386     C lBuffer - Length of buffer data will be read into
387     C fileHandle - Handle of already opened file
388     C myThid - Thread id calling this routine
389     INTEGER lBuffer
390     INTEGER fileHandle
391     INTEGER myThid
392    
393     C == Local variables ==
394     C ioUnit - Unit number associated with fileHandle
395     C I - Loop counter
396     C eMode - fileHandles error mode
397     CHARACTER*(MAX_LEN_FNAM) fNam
398     CHARACTER*(MAX_LEN_MBUF) msgBuf
399     INTEGER ioUnit
400     INTEGER I, iLo, iHi
401     INTEGER eMode
402    
403     C-- Get error mode
404     eMode = errorMode(fileHandle,myThid)
405    
406     C-- Check that file is active
407     IF ( unitStatus(fileHandle,myThid) .NE. busyUnit ) GOTO 999
408    
409     fNam = nameOfDFile(fileHandle,myThid)
410     iLo = IFNBLNK(fNam)
411     iHi = ILNBLNK(fNam)
412     ioUnit = dUnitNumber(fileHandle,myThid)
413     READ(ioUnit,ERR=899) (ioBuf_R8(I),I=1,lBuffer)
414    
415    
416     1000 CONTINUE
417     RETURN
418    
419     999 CONTINUE
420     WRITE(msgBuf,'(A)') ' S/R DFILE_READ_R8 '
421     CALL PRINT_ERROR( msgBuf , 1)
422     WRITE(msgBuf,'(A,I4,A)') ' Thread ', myThid, ' unit not open '
423     CALL PRINT_ERROR( msgBuf , 1)
424     IF ( eMode .EQ. errorModeSTOP ) THEN
425     STOP 'ABNORMAL END: S/R DFILE_READ_R8'
426     ENDIF
427     ioErrorCount(myThid) = ioErrorCount(myThid) + 1
428     GOTO 1000
429    
430     899 CONTINUE
431     WRITE(msgBuf,'(A)') ' S/R DFILE_READ_R8 '
432     CALL PRINT_ERROR( msgBuf , 1)
433 cnh 1.8 WRITE(msgBuf,'(A,I4,A)') ' Thread ', myThid,' error reading file'
434 cnh 1.3 CALL PRINT_ERROR( msgBuf , 1)
435     WRITE(msgBuf,'(A,A,A)') ' "', fNam(iLo:iHi),'"'
436 cnh 1.1 CALL PRINT_ERROR( msgBuf , 1)
437     IF ( eMode .EQ. errorModeSTOP ) THEN
438     STOP 'ABNORMAL END: S/R DFILE_READ_R8'
439     ENDIF
440     ioErrorCount(myThid) = ioErrorCount(myThid) + 1
441     GOTO 1000
442    
443     END
444    
445     SUBROUTINE DFILE_SET_RO
446     C /==========================================================\
447     C | SUBROUTINE DFILE_SET_RO |
448     C | o Sets new connections to be read-only. |
449     C \==========================================================/
450    
451     C == Global variables ==
452     #include "SIZE.h"
453     #include "EEPARAMS.h"
454     #include "DFILE.h"
455    
456     theAccessMode = accessModeRO
457    
458     RETURN
459     END
460    
461     SUBROUTINE DFILE_SET_RW
462     C /==========================================================\
463     C | SUBROUTINE DFILE_SET_RW |
464     C | o Sets new connections to be read-write |
465     C \==========================================================/
466    
467     C == Global variables ==
468     #include "SIZE.h"
469     #include "EEPARAMS.h"
470     #include "DFILE.h"
471    
472     theAccessMode = accessModeRW
473    
474     RETURN
475     END
476    
477     SUBROUTINE DFILE_SET_STOP_ON_ERROR
478     C /==========================================================\
479     C | SUBROUTINE DFILE_SET_STOP_ON_ERROR |
480     C | o Sets new connections to STOP on error |
481     C \==========================================================/
482    
483     C == Global variables ==
484     #include "SIZE.h"
485     #include "EEPARAMS.h"
486     #include "DFILE.h"
487    
488     theErrorMode = errorModeSTOP
489    
490     RETURN
491     END
492    
493     SUBROUTINE DFILE_SET_CONT_ON_ERROR
494     C /==========================================================\
495     C | SUBROUTINE DFILE_SET_CONT_ON_ERROR |
496     C | o Sets new connections to continue on error |
497     C \==========================================================/
498    
499     C == Global variables ==
500     #include "SIZE.h"
501     #include "EEPARAMS.h"
502     #include "DFILE.h"
503    
504     theErrorMode = errorModeCONT
505    
506     RETURN
507     END
508    
509     SUBROUTINE DFILE_WRITE_R4(
510     I lBuffer,
511     I nDims, dimList,
512     I fileHandle, fileId, myThid )
513     C /==========================================================\
514     C | SUBROUTINE DFILE_WRITE_R4 |
515     C | o Write record(s) to model dump file. |
516     C |==========================================================|
517     C | Controlling routine for doing actual I/O operations. |
518     C | Routine writes data to binary files. |
519     C | Could do elaborate write to netCDF or |
520     C | use C I/O primitives. For now we use plain F77 but the |
521     C | routine does write both data and metadata. Metadata is |
522     C | extra info. which describes the data - in this case it |
523     C | is information indicating the subregion of the global |
524     C | dataset being written out. |
525     C \==========================================================/
526    
527     C == Global variables ==
528     #include "SIZE.h"
529     #include "EEPARAMS.h"
530     #include "DFILE.h"
531    
532     C == Routine arguments ==
533     C lBuffer - Amount of data written
534     C nDims - Global and subset dimensionality
535     C dimList - List of global and subset extents
536     C fileHandle - Handle identifying actual IO unit
537     C myThid - Thread number of thread calling this
538     C routine
539     C eMode - error mode for this fileHandle
540     INTEGER lBuffer
541     INTEGER nDims
542     INTEGER dimList(nDims*3)
543     INTEGER fileHandle
544     INTEGER fileId
545     INTEGER myThid
546    
547     C == Local variables ==
548     C ioUnit - Unit number for I/O
549     C msgBuf - Textual printing message buffer
550     C eMode - Error mode for this file handle
551     INTEGER ioUnit
552 cnh 1.2 CHARACTER*(MAX_LEN_MBUF) msgBuf
553     CHARACTER*(MAX_LEN_FNAM) fNam
554 cnh 1.1 INTEGER eMode
555     INTEGER I
556    
557     C-- Set error mode
558     eMode = errorMode(fileHandle,myThid)
559    
560     C-- Check that file is active
561     IF ( unitStatus(fileHandle,myThid) .NE. busyUnit ) GOTO 999
562    
563     C-- Write data
564     ioUnit = dUnitNumber(fileHandle,myThid)
565     fNam = nameOfDFile(fileHandle,myThid)
566     WRITE(ioUnit,ERR=899) (ioBuf_R4(I),I=1,lBuffer)
567    
568     C-- Now write meta information
569 cnh 1.8 IF ( metaDataStatus(fileHandle,myThid) .EQ.
570     & metaDataNotWritten ) THEN
571 cnh 1.1 ioUnit = mUnitNumber(fileHandle,myThid)
572    
573     WRITE(msgBuf,'(A)') '// START OF META DATA'
574     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
575    
576 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' id =[ ','/* Identifier */'
577 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
578 cnh 1.8 CALL PRINT_LIST_I( fileId, 1, INDEX_NONE, .FALSE., .TRUE.,
579     & ioUnit )
580 adcroft 1.5 WRITE(msgBuf,'(A)') ' ]; '
581 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
582    
583 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' nDims =[ ','/* Number of dimensions */'
584 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
585 cnh 1.8 CALL PRINT_LIST_I( nDims, 1, INDEX_NONE, .FALSE., .TRUE.,
586     & ioUnit )
587 adcroft 1.5 WRITE(msgBuf,'(A)') ' ]; '
588 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
589    
590 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' dimList =[ ',
591 cnh 1.1 & '/* Global1, local min1, local max1, ... */'
592     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
593     DO I=1,nDims
594 cnh 1.8 CALL PRINT_LIST_I( dimList((I-1)*3+1), 3, INDEX_NONE,
595     & I.NE.nDims, .FALSE., ioUnit )
596 cnh 1.1 ENDDO
597 adcroft 1.5 WRITE(msgBuf,'(A)') ' ]; '
598     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
599    
600     WRITE(msgBuf,'(A,A)') ' format =[ ','/* Field format */'
601     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
602     WRITE(msgBuf,'(16X,A)') '''float32'''
603     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
604     WRITE(msgBuf,'(A)') ' ]; '
605 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
606    
607     WRITE(msgBuf,'(A)') '// END OF META DATA'
608     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
609     metaDataStatus(fileHandle,myThid) = metaDataWritten
610     ENDIF
611    
612     1000 CONTINUE
613     RETURN
614    
615     999 CONTINUE
616     WRITE(msgBuf,'(A)') ' S/R DFILE_WRITE_R4 '
617     CALL PRINT_ERROR( msgBuf , 1)
618     WRITE(msgBuf,'(A,A)') ' Thread ', myThid, ' unit not open '
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     899 CONTINUE
627     WRITE(msgBuf,'(A)') ' S/R DFILE_WRITE_R4 '
628     CALL PRINT_ERROR( msgBuf , 1)
629     WRITE(msgBuf,'(A,A)') ' Thread ', myThid, ' write error '
630     CALL PRINT_ERROR( msgBuf , 1)
631     WRITE(msgBuf,'(A,A)') ' File ', fNam
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     END
640    
641     SUBROUTINE DFILE_WRITE_R8(
642     I lBuffer,
643     I nDims, dimList,
644     I fileHandle, fileId, myThid )
645     C /==========================================================\
646     C | SUBROUTINE DFILE_WRITE_R8 |
647     C | o Write record(s) to model dump file. |
648     C |==========================================================|
649     C | Controlling routine for doing actual I/O operations. |
650     C | Routine writes data to binary files. |
651     C | Could do elaborate write to netCDF or |
652     C | use C I/O primitives. For now we use plain F77 but the |
653     C | routine does write both data and metadata. Metadata is |
654     C | extra info. which describes the data - in this case it |
655     C | is information indicating the subregion of the global |
656     C | dataset being written out. |
657     C \==========================================================/
658    
659     C == Global variables ==
660     #include "SIZE.h"
661     #include "EEPARAMS.h"
662     #include "DFILE.h"
663    
664     C == Routine arguments ==
665     C buffer - Subset data to write
666     C lBuffer - Amount of data written
667     C nDims - Global and subset dimensionality
668     C dimList - List of global and subset extents
669     C fileHandle - Handle identifying actual IO unit
670     C myThid - Thread number of thread calling this
671     C routine
672     C eMode - error mode for this fileHandle
673     INTEGER lBuffer
674     INTEGER nDims
675     INTEGER dimList(nDims*3)
676     INTEGER fileHandle
677     INTEGER fileId
678     INTEGER myThid
679    
680     C == Local variables ==
681     C ioUnit - Unit number for I/O
682     C msgBuf - Textual printing message buffer
683     C eMode - Error mode for this file handle
684     INTEGER ioUnit
685 cnh 1.2 CHARACTER*(MAX_LEN_MBUF) msgBuf
686     CHARACTER*(MAX_LEN_FNAM) fNam
687 cnh 1.1 INTEGER eMode
688     INTEGER I
689    
690     C-- Set error mode
691     eMode = errorMode(fileHandle,myThid)
692    
693     C-- Check that file is active
694     IF ( unitStatus(fileHandle,myThid) .NE. busyUnit ) GOTO 999
695    
696     C-- Write data
697     ioUnit = dUnitNumber(fileHandle,myThid)
698     fNam = nameOfDFile(fileHandle,myThid)
699     WRITE(ioUnit,ERR=899) (ioBuf_R8(I),I=1,lBuffer)
700    
701     C-- Now write meta information
702 cnh 1.8 IF ( metaDataStatus(fileHandle,myThid) .EQ.
703     & metaDataNotWritten ) THEN
704 cnh 1.1 ioUnit = mUnitNumber(fileHandle,myThid)
705    
706     WRITE(msgBuf,'(A)') '// START OF META DATA'
707     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
708    
709 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' id =[ ','/* Identifier */'
710 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
711 cnh 1.8 CALL PRINT_LIST_I( fileId, 1, INDEX_NONE, .FALSE., .TRUE.,
712     & ioUnit )
713 adcroft 1.5 WRITE(msgBuf,'(A)') ' ]; '
714 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
715    
716 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' nDims =[ ','/* Number of dimensions */'
717 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
718 cnh 1.8 CALL PRINT_LIST_I( nDims, 1, INDEX_NONE, .FALSE., .TRUE.,
719     & ioUnit )
720 adcroft 1.5 WRITE(msgBuf,'(A)') ' ]; '
721 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
722    
723 adcroft 1.5 WRITE(msgBuf,'(A,A)') ' dimList =[ ',
724 cnh 1.1 & '/* Global1, local min1, local max1, ... */'
725     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
726     DO I=1,nDims
727 cnh 1.8 CALL PRINT_LIST_I( dimList((I-1)*3+1), 3, INDEX_NONE,
728     & I.NE.nDims, .FALSE., ioUnit )
729 cnh 1.1 ENDDO
730 adcroft 1.5 WRITE(msgBuf,'(A)') ' ]; '
731 cnh 1.1 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
732 adcroft 1.5
733     WRITE(msgBuf,'(A,A)') ' format =[ ','/* Field format */'
734     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
735     WRITE(msgBuf,'(16X,A)') '''float64'''
736     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
737     WRITE(msgBuf,'(A)') ' ]; '
738     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
739    
740 cnh 1.1 WRITE(msgBuf,'(A)') '// END OF META DATA'
741     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT , 1)
742     metaDataStatus(fileHandle,myThid) = metaDataWritten
743     ENDIF
744    
745     1000 CONTINUE
746     RETURN
747    
748     999 CONTINUE
749     WRITE(msgBuf,'(A)') ' S/R DFILE_WRITE_R8 '
750     CALL PRINT_ERROR( msgBuf , 1)
751     WRITE(msgBuf,'(A,A)') ' Thread ', myThid, ' unit not open '
752     CALL PRINT_ERROR( msgBuf , 1)
753     IF ( eMode .EQ. errorModeSTOP ) THEN
754     STOP 'ABNORMAL END: S/R DFILE_WRITE_R8'
755     ENDIF
756     ioErrorCount(myThid) = ioErrorCount(myThid) + 1
757     GOTO 1000
758    
759     899 CONTINUE
760     WRITE(msgBuf,'(A)') ' S/R DFILE_WRITE_R8 '
761     CALL PRINT_ERROR( msgBuf , 1)
762     WRITE(msgBuf,'(A,A)') ' Thread ', myThid, ' write error '
763     CALL PRINT_ERROR( msgBuf , 1)
764     WRITE(msgBuf,'(A,A)') ' File ', fNam
765     CALL PRINT_ERROR( msgBuf , 1)
766     IF ( eMode .EQ. errorModeSTOP ) THEN
767     STOP 'ABNORMAL END: S/R DFILE_WRITE_R8'
768     ENDIF
769     ioErrorCount(myThid) = ioErrorCount(myThid) + 1
770     GOTO 1000
771    
772     END
  ViewVC Help
Powered by ViewVC 1.1.22