/[MITgcm]/MITgcm/pkg/rw/read_mflds.F
ViewVC logotype

Contents of /MITgcm/pkg/rw/read_mflds.F

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


Revision 1.2 - (show annotations) (download)
Tue Oct 23 15:17:24 2007 UTC (16 years, 8 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint59j
Changes since 1.1: +11 -4 lines
fix for multi-threaded run

1 C $Header: /u/gcmpack/MITgcm/pkg/rw/read_mflds.F,v 1.1 2007/10/22 13:20:07 jmc Exp $
2 C $Name: $
3
4 #include "RW_OPTIONS.h"
5
6 C-- File read_mflds.F: Routines to handle reading Multi-Fields File (+ meta file)
7 C-- Contents
8 C-- o READ_MFLDS_INIT
9 C-- o READ_MFLDS_SET
10 C-- o READ_MFLDS_3D_RL
11 C-- o READ_MFLDS_CHECK
12
13 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
14 CBOP
15 C !ROUTINE: READ_MFLDS_INIT
16 C !INTERFACE:
17 SUBROUTINE READ_MFLDS_INIT(
18 I myThid )
19
20 C !DESCRIPTION:
21 C Initialise Multi-Fields read variables in common block
22
23 C !USES:
24 IMPLICIT NONE
25 c#include "SIZE.h"
26 #include "EEPARAMS.h"
27 #include "RW_MFLDS.h"
28
29 C !INPUT/OUTPUT PARAMETERS:
30 C myThid :: my Thread Id. number
31 INTEGER myThid
32 CEOP
33
34 C !LOCAL VARIABLES:
35 C i :: loop counter
36 INTEGER i
37 C- for debug print:
38 c CHARACTER*(MAX_LEN_MBUF) msgBuf
39
40 C-----
41
42 C- Initialise variables in common block:
43 thirdDim = 0
44 nFl3D = 0
45 nFlds = 0
46 nMissFld = 0
47 mFldsFile = ' '
48 DO i=1,sizFldList
49 fldList(i) = ' '
50 fldMiss(i) = ' '
51 ENDDO
52
53 RETURN
54 END
55
56 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
57 CBOP
58 C !ROUTINE: READ_MFLDS_SET
59 C !INTERFACE:
60 SUBROUTINE READ_MFLDS_SET(
61 I fName,
62 O nbFields, filePrec,
63 I fileDim3, myIter, myThid )
64
65 C !DESCRIPTION:
66 C This is the controlling routine for preparing Multi-Fields read
67 C by reading the corresponding meta file.
68 C the meta-file content is stored in common block (header: RW_MFLDS.h)
69 C to be reachable by all threads
70
71 C Note: 1) Output arguments should not be shared variables (= not in common block)
72 C 2) Only master-thread returns a valid filePrec (others just return 0)
73
74 C !USES:
75 IMPLICIT NONE
76 #include "SIZE.h"
77 #include "EEPARAMS.h"
78 #include "PARAMS.h"
79 #include "RW_MFLDS.h"
80
81 C !INPUT/OUTPUT PARAMETERS:
82 C fName :: current MFLDS file name (prefix) to read
83 C nbFields :: Number of fields in current MFLDS file
84 C filePrec :: data-precision in current MFLDS file
85 C fileDim3 :: 3rd dimension of fields in current MFLDS file
86 C myIter :: Iteration number
87 C myThid :: my Thread Id. number
88 CHARACTER*(MAX_LEN_FNAM) fName
89 INTEGER nbFields
90 INTEGER filePrec
91 INTEGER fileDim3
92 INTEGER myIter
93 INTEGER myThid
94 CEOP
95
96 C !FUNCTIONS
97 INTEGER ILNBLNK
98 EXTERNAL ILNBLNK
99
100 C !LOCAL VARIABLES:
101 C- do change dir. (using mdsioLocalDir):
102 LOGICAL useCurrentDir
103 C- output of MDS_READ_META :
104 INTEGER nSizD, nSizT
105 PARAMETER( nSizD = 5 , nSizT = 20 )
106 CHARACTER*(MAX_LEN_PREC/2) simulName
107 CHARACTER*(MAX_LEN_MBUF/2) titleLine
108 INTEGER nDims, nTimRec
109 INTEGER dimList(3,nSizD)
110 _RL timList(nSizT)
111 INTEGER nRecords, fileIter
112 C- for debug print:
113 INTEGER i, j, ioUnit
114 CHARACTER*(MAX_LEN_MBUF) msgBuf
115
116 C-----
117
118 C- Initialise output arguments:
119 nbFields = 0
120 filePrec = 0
121
122 #ifdef RW_SAFE_MFLDS
123 i = ILNBLNK(mFldsFile)
124 IF ( i.NE.0 ) THEN
125 i = MIN(i, MAX_LEN_MBUF-48-34 )
126 WRITE(msgBuf,'(4A)') 'READ_MFLDS_SET: ',
127 & 'MFLDS file-name already set to: ',mFldsFile(1:i)
128 CALL PRINT_ERROR( msgBuf, myThid )
129 STOP 'ABNORMAL END: S/R READ_MFLDS_SET (fileName)'
130 ENDIF
131 _BARRIER
132 #endif /* RW_SAFE_MFLDS */
133 _BEGIN_MASTER( myThid )
134
135 C- Initialise variables in common block:
136 thirdDim = fileDim3
137 nFl3D = 0
138 nFlds = 0
139 nMissFld = 0
140 mFldsFile = fName
141 DO i=1,sizFldList
142 fldList(i) = ' '
143 fldMiss(i) = ' '
144 ENDDO
145
146 #ifdef ALLOW_MDSIO
147 useCurrentDir = .FALSE.
148 nDims = nSizD
149 nFlds = sizFldList
150 nTimRec = nSizT
151 CALL MDS_READ_META(
152 I fName,
153 O simulName,
154 O titleLine,
155 O filePrec,
156 U nDims, nFlds, nTimRec,
157 O dimList, fldList, timList,
158 O nRecords, fileIter,
159 I useCurrentDir, myThid )
160 #endif /* ALLOW_MDSIO */
161
162 C- evaluate Nb of 3.D fields (used if mix 3-D & 2-D fields in file):
163 nFl3D = 0
164 IF ( nFlds.GE.1 ) THEN
165 IF ( nDims.EQ.2 .AND. thirdDim.GT.1
166 & .AND. nFlds.LT.nRecords ) THEN
167 IF ( MOD( nRecords-nFlds , thirdDim-1 ) .EQ. 0 )
168 & nFl3D = (nRecords-nFlds)/(thirdDim-1)
169 ENDIF
170 IF ( nFlds.NE.nRecords .AND. nFl3D.EQ.0 ) THEN
171 C- here we have a problem
172 WRITE(msgBuf,'(A,I5,A,I4,A)')
173 & 'READ_MFLDS_SET: Pb with Nb of records=', nRecords,
174 & ' (3rd-Dim=', thirdDim,')'
175 CALL PRINT_ERROR( msgBuf, myThid )
176 WRITE(msgBuf,'(A,I5,A,I4,A)')
177 & ' does not match Nb of flds=', nFlds
178 CALL PRINT_ERROR( msgBuf, myThid )
179 STOP 'ABNORMAL END: S/R READ_MFLDS_SET (Nb-records Pb)'
180 ENDIF
181 c IF ( nFl3D.EQ.0 ) nFl3D = nFlds
182 ENDIF
183
184 C- write to Standard Output
185 IF ( debugLevel.GE.debLevA ) THEN
186 ioUnit = standardMessageUnit
187 i = ILNBLNK(simulName)
188 IF ( i.GE.1 ) THEN
189 WRITE(msgBuf,'(3A)') ' simulName=>', simulName(1:i), '<'
190 CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
191 ENDIF
192 i = ILNBLNK(titleLine)
193 IF ( i.GE.1 ) THEN
194 WRITE(msgBuf,'(3A)') ' titleLine=>', titleLine(1:i), '<'
195 CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
196 ENDIF
197 WRITE(msgBuf,'(2(A,I4),A,I10)')
198 & ' nRecords =', nRecords, ' ; filePrec =', filePrec,
199 & ' ; fileIter =', fileIter
200 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
201 WRITE(msgBuf,'(A,I4,A)') ' nDims =', nDims, ' , dims:'
202 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
203 DO j=1,nDims
204 WRITE(msgBuf,'(I4,A,3I4)') j,':',(dimList(i,j),i=1,3)
205 CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
206 ENDDO
207 WRITE(msgBuf,'(3(A,I4))')
208 & ' nFlds =', nFlds, ' , nFl3D =', nFl3D, ' , fields:'
209 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
210 DO j=1,nFlds,20
211 WRITE(msgBuf,'(20(A2,A8,A))')
212 & (' >', fldList(i), '<', i=j,MIN(j+19,nFlds) )
213 CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
214 ENDDO
215 WRITE(msgBuf,'(A,I4,A)') ' nTimRec =',nTimRec,' , timeList:'
216 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
217 IF ( nTimRec.GE.1 ) THEN
218 WRITE(msgBuf,'(1P20E20.12)') (timList(i),i=1,nTimRec)
219 CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
220 ENDIF
221 ENDIF
222
223 _END_MASTER( myThid )
224 _BARRIER
225
226 C- set output arguments:
227 nbFields = nFlds
228
229 RETURN
230 END
231
232 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
233 CBOP
234 C !ROUTINE: READ_MFLDS_3D_RL
235 C !INTERFACE:
236 SUBROUTINE READ_MFLDS_3D_RL(
237 I fldName,
238 O field,
239 U nj,
240 I fPrec, nNz, myIter, myThid )
241
242 C !DESCRIPTION:
243 C Read, from a Multi-Fields binary file, field "fldName" into array "field"
244 C record Nb "nj" is search through the field-list (from meta-file) which
245 C has been set before (calling READ_MFLDS_SET).
246 C In case nFlds is <=0 , by-pass the search and directly read record number "nj"
247
248 C !USES:
249 IMPLICIT NONE
250 #include "SIZE.h"
251 #include "EEPARAMS.h"
252 #include "PARAMS.h"
253 #include "RW_MFLDS.h"
254
255 C !INPUT/OUTPUT PARAMETERS:
256 C fldName :: Name of the field to read
257 C field :: Output array to read in
258 C nj (in) :: number of the record (in file) just before the one to read
259 C nj (out):: number of the record (from current file) which was read in
260 C fPrec :: File precision (number of bits per word, = 32 or 64)
261 C nNz :: Number of levels to read in
262 C myIter :: Iteration number
263 C myThid :: My Thread Id number
264 CHARACTER*(8) fldName
265 _RL field(*)
266 INTEGER nj
267 INTEGER fPrec
268 INTEGER nNz
269 INTEGER myIter
270 INTEGER myThid
271 CEOP
272
273 C !FUNCTIONS
274 INTEGER ILNBLNK
275 EXTERNAL ILNBLNK
276
277 C !LOCAL VARIABLES:
278 INTEGER j, iL, ioUnit
279 CHARACTER*(2) fType
280 CHARACTER*(MAX_LEN_FNAM) fName
281 CHARACTER*(MAX_LEN_MBUF) msgBuf
282
283 C-----
284
285 iL = ILNBLNK(mFldsFile)
286 #ifdef RW_SAFE_MFLDS
287 IF ( iL.EQ.0 ) THEN
288 WRITE(msgBuf,'(2A,I4)') 'READ_MFLDS_3D_RL: ',
289 & 'empty MFLDS file-name'
290 CALL PRINT_ERROR( msgBuf, myThid )
291 STOP 'ABNORMAL END: S/R READ_MFLDS_3D_RL (fileName)'
292 ENDIF
293 #endif /* RW_SAFE_MFLDS */
294
295 ioUnit = standardMessageUnit
296 IF ( nFlds.GE.1 ) THEN
297 C-- Search for "fldName" in list of field-names:
298 nj = 0
299 DO j=1,nFlds
300 IF ( fldName.EQ.fldList(j) .AND. nj.EQ.0 ) nj = j
301 ENDDO
302 IF ( nj.EQ.0 ) THEN
303 C- record unsuccessful search:
304 _BEGIN_MASTER( myThid )
305 nMissFld = nMissFld + 1
306 j = MIN(nMissFld,sizFldList)
307 fldMiss(j) = fldName
308 _END_MASTER( myThid )
309 IF ( debugLevel.GE.debLevA ) THEN
310 iL = ILNBLNK(mFldsFile)
311 iL = MIN(iL,MAX_LEN_MBUF-54-20)
312 WRITE(msgBuf,'(5A)') 'READ_MFLDS_3D_RL: ',
313 & 'field: "',fldName,'" missing in file: ',mFldsFile(1:iL)
314 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
315 ENDIF
316 ELSE
317 C- convert from field Number to record number (if mix of 3D & 2D flds)
318 j = nj
319 IF ( nj.GT.nFl3D ) nj = nj + nFl3D*(thirdDim-1)
320 IF ( debugLevel.GE.debLevA ) THEN
321 WRITE(msgBuf,'(3A,2(A,I4))') 'READ_MFLDS_3D_RL: ',
322 & 'read field: "',fldName,'", #',j,' in fldList, rec=',nj
323 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
324 ENDIF
325 ENDIF
326 ELSEIF ( nj.GE.0 ) THEN
327 C- increment record number
328 nj = nj + 1
329 IF ( debugLevel.GE.debLevA ) THEN
330 WRITE(msgBuf,'(3A,2(A,I4))') 'READ_MFLDS_3D_RL: ',
331 & 'no fldList, try to read field "',fldName, '", rec=',nj
332 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
333 ENDIF
334 ENDIF
335
336 IF ( nj.GE.1 ) THEN
337 C-- read in array "field"
338 fName = mFldsFile
339 fType = 'RL'
340 #ifdef ALLOW_MDSIO
341 CALL MDSREADFIELD( fName, fPrec, fType,
342 & nNz, field, nj, myThid )
343 #endif
344 c CALL READ_REC_3D_RL( fName, fPrec, nNz, field, nj, myIter, myThid )
345 ENDIF
346
347 RETURN
348 END
349
350 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
351 CBOP
352 C !ROUTINE: READ_MFLDS_CHECK
353 C !INTERFACE:
354 SUBROUTINE READ_MFLDS_CHECK(
355 O errList,
356 U nbErr,
357 I myIter, myThid )
358
359 C !DESCRIPTION:
360 C After reading a Multi-Fields binary file, check (and report)
361 C for missing fields (attempted to read but not found).
362 C
363 C Note: If missing fields, print error msg but take no action (no stop)
364 C but return number of missing fields (+ list, if nbErr_inputArg > 0)
365 C Depending on the calling context, may choose to stop or to continue
366
367 C !USES:
368 IMPLICIT NONE
369 #include "SIZE.h"
370 #include "EEPARAMS.h"
371 #include "PARAMS.h"
372 #include "RW_MFLDS.h"
373
374 C !INPUT PARAMETERS:
375 C nbErr :: max size of array errList
376 C myIter :: Iteration number
377 C myThid :: My Thread Id number
378 C !OUTPUT PARAMETERS:
379 C errList :: List of missing fields (attempted to read but not found)
380 C nbErr :: Number of missing fields (attempted to read but not found)
381 CHARACTER*(8) errList(*)
382 INTEGER nbErr
383 INTEGER myIter
384 INTEGER myThid
385 CEOP
386
387 C !FUNCTIONS
388 INTEGER ILNBLNK
389 EXTERNAL ILNBLNK
390
391 C !LOCAL VARIABLES:
392 INTEGER i, j, nj, iL, ioUnit
393 CHARACTER*(MAX_LEN_MBUF) msgBuf
394
395 C-----
396
397 iL = ILNBLNK(mFldsFile)
398 #ifdef RW_SAFE_MFLDS
399 IF ( iL.EQ.0 ) THEN
400 WRITE(msgBuf,'(2A,I4)') 'READ_MFLDS_CHECK: ',
401 & 'empty MFLDS file-name'
402 CALL PRINT_ERROR( msgBuf, myThid )
403 STOP 'ABNORMAL END: S/R READ_MFLDS_CHECK (fileName)'
404 ENDIF
405 #endif /* RW_SAFE_MFLDS */
406
407 C-- Initialise output arguments
408 DO j=1,nbErr
409 errList(j) = ' '
410 ENDDO
411
412 IF ( nMissFld.GE.1 ) THEN
413 C-- Attempted to read some fields that were not in the current MFLDS file
414 C => report by printing Error Msg:
415 ioUnit = errorMessageUnit
416 WRITE(msgBuf,'(3A)') 'READ_MFLDS_CHECK: ',
417 & 'reading from file: ', mFldsFile(1:iL)
418 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
419 WRITE(msgBuf,'(2A,I4,A)') 'READ_MFLDS_CHECK: ',
420 & 'which contains ', nFlds, ' fields :'
421 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
422 DO j=1,nFlds,20
423 WRITE(msgBuf,'(20(A2,A8,A))')
424 & (' >', fldList(i), '<', i=j,MIN(j+19,nFlds) )
425 CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
426 ENDDO
427 WRITE(msgBuf,'(A,I4,A)') 'READ_MFLDS_CHECK: ',
428 & nMissFld, ' field(s) is/are missing :'
429 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
430 nj = MIN( nMissFld, sizFldList )
431 DO j=1,nj,20
432 WRITE(msgBuf,'(20(A2,A8,A))')
433 & (' >', fldMiss(i), '<', i=j,MIN(j+19,nj) )
434 CALL PRINT_MESSAGE(msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
435 ENDDO
436
437 C- Size problem:
438 IF ( nMissFld.GT.sizFldList ) THEN
439 WRITE(msgBuf,'(2A,I4)') 'READ_MFLDS_CHECK: ',
440 & 'missing fields list has been truncated to', sizFldList
441 CALL PRINT_ERROR( msgBuf, myThid )
442 STOP 'ABNORMAL END: S/R READ_MFLDS_CHECK (list-size Pb)'
443 ENDIF
444
445 C- Fill the error output list (up to the Max size: nbErr)
446 nj = MIN( nMissFld, nbErr )
447 DO j=1,nj
448 errList(j) = fldMiss(j)
449 ENDDO
450 ELSE
451 C-- Normal end : print msg before resetting "mFldsFile"
452 ioUnit = standardMessageUnit
453 IF ( debugLevel .GE. debLevA ) THEN
454 WRITE(msgBuf,'(3A)') 'READ_MFLDS_CHECK: ',
455 c & '- end reading file: ', mFldsFile(1:iL)
456 c & '- normal end ; reset mFldsFile: ', mFldsFile(1:iL)
457 & '- normal end ; reset MFLDS file-name: ', mFldsFile(1:iL)
458 CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
459 ENDIF
460
461 ENDIF
462
463 C- Return the number of missing fields
464 nbErr = nMissFld
465
466 #ifdef RW_SAFE_MFLDS
467 _BARRIER
468 _BEGIN_MASTER( myThid )
469 C-- Reset MFLDS file name:
470 mFldsFile = ' '
471 _END_MASTER( myThid )
472 _BARRIER
473 #endif /* RW_SAFE_MFLDS */
474
475 RETURN
476 END

  ViewVC Help
Powered by ViewVC 1.1.22