/[MITgcm]/MITgcm/pkg/mdsio/mdsio_readvector.F
ViewVC logotype

Annotation of /MITgcm/pkg/mdsio/mdsio_readvector.F

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


Revision 1.15 - (hide annotations) (download)
Tue Sep 1 19:00:15 2009 UTC (14 years, 10 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint62v, checkpoint62u, checkpoint62t, checkpoint62c, checkpoint62s, checkpoint62r, checkpoint62q, checkpoint62p, checkpoint62a, checkpoint62g, checkpoint62f, checkpoint62e, checkpoint62k, checkpoint62j, checkpoint62i, checkpoint62h, checkpoint62o, checkpoint62n, checkpoint62m, checkpoint62l, checkpoint62w, checkpoint62z, checkpoint62y, checkpoint62x, checkpoint63g, checkpoint64, checkpoint62, checkpoint63, checkpoint63p, checkpoint63q, checkpoint63r, checkpoint63s, checkpoint63l, checkpoint63m, checkpoint63n, checkpoint63o, checkpoint63h, checkpoint63i, checkpoint63j, checkpoint63k, checkpoint63d, checkpoint63e, checkpoint63f, checkpoint63a, checkpoint63b, checkpoint63c, checkpoint62b, checkpoint64p, checkpoint64i, checkpoint64h, checkpoint64k, checkpoint64j, checkpoint64m, checkpoint64l, checkpoint64o, checkpoint64n, checkpoint64a, checkpoint64c, checkpoint64b, checkpoint64e, checkpoint64d, checkpoint64g, checkpoint64f, checkpoint62d, checkpoint61z, checkpoint61v, checkpoint61w, checkpoint61x, checkpoint61y
Changes since 1.14: +3 -1 lines
add a stop if ALLOW_AUTODIFF is undef

1 jmc 1.15 C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_readvector.F,v 1.14 2009/02/03 23:10:28 jmc Exp $
2 heimbach 1.2 C $Name: $
3 adcroft 1.1
4     #include "MDSIO_OPTIONS.h"
5    
6     SUBROUTINE MDSREADVECTOR(
7     I fName,
8     I filePrec,
9     I arrType,
10     I narr,
11     O arr,
12     I bi,
13     I bj,
14     I irecord,
15     I myThid )
16 jmc 1.13
17 adcroft 1.1 C Arguments:
18     C
19 jmc 1.13 C fName string :: base name for file to read
20     C filePrec integer :: number of bits per word in file (32 or 64)
21     C arrType char(2) :: declaration of "arr": either "RS" or "RL"
22     C narr integer :: size of third dimension: normally either 1 or Nr
23     C arr RS/RL :: array to read into, arr(narr)
24     c bi integer :: x tile index
25     c bj integer :: y tile index
26     C irecord integer :: record number to read
27     C myThid integer :: thread identifier
28 adcroft 1.1 C
29     C Created: 03/26/99 eckert@mit.edu
30     C Modified: 03/29/99 adcroft@mit.edu + eckert@mit.edu
31     C Fixed to work work with _RS and _RL declarations
32     C Modified: 07/27/99 eckert@mit.edu
33     C Customized for state estimation (--> active_file_control.F)
34    
35 jmc 1.13 IMPLICIT NONE
36     C Global variables / COMMON blocks
37 adcroft 1.1 #include "SIZE.h"
38     #include "EEPARAMS.h"
39     #include "PARAMS.h"
40 heimbach 1.6 #include "EESUPPORT.h"
41 adcroft 1.1
42     C Routine arguments
43 jmc 1.13 CHARACTER*(*) fName
44     INTEGER filePrec
45     CHARACTER*(2) arrType
46     INTEGER narr
47 heimbach 1.9 _RL arr(narr)
48 jmc 1.13 INTEGER bi,bj
49     INTEGER irecord
50     INTEGER myThid
51 adcroft 1.1
52 jmc 1.14 #ifdef ALLOW_AUTODIFF
53 jmc 1.13
54 adcroft 1.1 C Functions
55 jmc 1.13 INTEGER ILNBLNK
56     INTEGER MDS_RECLEN
57 adcroft 1.1 C Local variables
58 jmc 1.13 CHARACTER*(MAX_LEN_FNAM) dataFName,pfName
59     INTEGER iG,jG,irec,dUnit,IL,pIL
60     LOGICAL exst
61     LOGICAL globalFile,fileIsOpen
62     INTEGER length_of_rec
63     CHARACTER*(MAX_LEN_MBUF) msgBuf
64 heimbach 1.6
65     cph(
66     cph Deal with useSingleCpuIO
67     cph Not extended here for EXCH2
68 jmc 1.13 INTEGER k,l
69     INTEGER vec_size
70 heimbach 1.6 Real*4 xy_buffer_r4(narr*nPx*nPy)
71     Real*8 xy_buffer_r8(narr*nPx*nPy)
72     Real*8 global (narr*nPx*nPy)
73     _RL local(narr)
74     cph)
75 adcroft 1.1 C ------------------------------------------------------------------
76    
77 heimbach 1.6 vec_size = narr*nPx*nPy
78 jmc 1.13
79     C Only DO I/O IF I am the master thread
80 adcroft 1.1 _BEGIN_MASTER( myThid )
81    
82     C Record number must be >= 1
83 jmc 1.13 IF (irecord .LT. 1) THEN
84     WRITE(msgBuf,'(A,I9.8)')
85 adcroft 1.1 & ' MDSREADVECTOR: argument irecord = ',irecord
86 jmc 1.13 CALL PRINT_ERROR( msgBuf, myThid )
87     WRITE(msgBuf,'(A)')
88 adcroft 1.1 & ' MDSREADVECTOR: invalid value for irecord'
89 jmc 1.13 CALL PRINT_ERROR( msgBuf, myThid )
90     STOP 'ABNORMAL END: S/R MDSREADVECTOR'
91     ENDIF
92 adcroft 1.1
93     C Assume nothing
94     globalFile = .FALSE.
95     fileIsOpen = .FALSE.
96 heimbach 1.3 IL = ILNBLNK( fName )
97     pIL = ILNBLNK( mdsioLocalDir )
98    
99     C Assign special directory
100 jmc 1.13 IF ( mdsioLocalDir .NE. ' ' ) THEN
101     WRITE(pfName,'(2A)')
102 heimbach 1.4 & mdsioLocalDir(1:pIL), fName(1:IL)
103 jmc 1.13 ELSE
104     pfName= fName
105     ENDIF
106 heimbach 1.3 pIL=ILNBLNK( pfName )
107 adcroft 1.1
108     C Assign a free unit number as the I/O channel for this routine
109 jmc 1.13 CALL MDSFINDUNIT( dUnit, myThid )
110 adcroft 1.1
111 jmc 1.13 IF ( .not. useSingleCPUIO ) THEN
112 heimbach 1.6
113 adcroft 1.1 C Check first for global file with simple name (ie. fName)
114     dataFName = fName
115 jmc 1.13 INQUIRE( file=dataFName, exist=exst )
116     IF (exst) THEN
117     IF ( debugLevel .GE. debLevB ) THEN
118     WRITE(msgBuf,'(A,A)')
119 jmc 1.8 & ' MDSREADVECTOR: opening global file: ',dataFName(1:IL)
120 jmc 1.13 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
121     & SQUEEZE_RIGHT , myThid )
122     ENDIF
123 adcroft 1.1 globalFile = .TRUE.
124 jmc 1.13 ENDIF
125 adcroft 1.1
126     C If negative check for global file with MDS name (ie. fName.data)
127 jmc 1.13 IF (.NOT. globalFile) THEN
128     WRITE(dataFName,'(2A)') fName(1:IL),'.data'
129     INQUIRE( file=dataFName, exist=exst )
130     IF (exst) THEN
131     IF ( debugLevel .GE. debLevB ) THEN
132     WRITE(msgBuf,'(A,A)')
133 jmc 1.8 & ' MDSREADVECTOR: opening global file: ',dataFName(1:IL+5)
134 jmc 1.13 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
135     & SQUEEZE_RIGHT , myThid )
136     ENDIF
137 adcroft 1.1 globalFile = .TRUE.
138 jmc 1.13 ENDIF
139     ENDIF
140 adcroft 1.1
141     C If we are reading from a global file then we open it here
142 jmc 1.13 IF (globalFile) THEN
143     length_of_rec=MDS_RECLEN( filePrec, narr, myThid )
144     OPEN( dUnit, file=dataFName, status='old',
145 adcroft 1.1 & access='direct', recl=length_of_rec )
146     fileIsOpen=.TRUE.
147 jmc 1.13 ENDIF
148 adcroft 1.1
149     C Loop over all tiles
150 jmc 1.13 c DO bj=1,nSy
151     c DO bi=1,nSx
152 adcroft 1.1 C If we are reading from a tiled MDS file then we open each one here
153 jmc 1.13 IF (.NOT. globalFile) THEN
154 adcroft 1.1 iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
155     jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
156 jmc 1.13 WRITE(dataFName,'(2A,I3.3,A,I3.3,A)')
157 heimbach 1.3 & pfName(1:pIL),'.',iG,'.',jG,'.data'
158 jmc 1.13 INQUIRE( file=dataFName, exist=exst )
159     C Of course, we only open the file IF the tile is "active"
160 adcroft 1.1 C (This is a place-holder for the active/passive mechanism)
161 jmc 1.13 IF (exst) THEN
162     IF ( debugLevel .GE. debLevB ) THEN
163     WRITE(msgBuf,'(A,A)')
164 jmc 1.8 & ' MDSREADVECTOR: opening file: ',dataFName(1:pIL+13)
165 jmc 1.13 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
166     & SQUEEZE_RIGHT , myThid )
167     ENDIF
168     length_of_rec=MDS_RECLEN( filePrec, narr, myThid )
169     OPEN( dUnit, file=dataFName, status='old',
170 adcroft 1.1 & access='direct', recl=length_of_rec )
171     fileIsOpen=.TRUE.
172 jmc 1.13 ELSE
173 adcroft 1.1 fileIsOpen=.FALSE.
174 jmc 1.13 WRITE(msgBuf,'(4A)')
175 jmc 1.8 & ' MDSREADVECTOR: opening file: ',fName(1:IL),
176     & ' , ',dataFName(1:pIL+13)
177 jmc 1.13 CALL PRINT_ERROR( msgBuf, myThid )
178     WRITE(msgBuf,'(A)')
179 adcroft 1.1 & ' MDSREADVECTOR: un-active tiles not implemented yet'
180 jmc 1.13 CALL PRINT_ERROR( msgBuf, myThid )
181     STOP 'ABNORMAL END: S/R MDSREADVECTOR'
182     ENDIF
183     ENDIF
184     IF (fileIsOpen) THEN
185     IF (globalFile) THEN
186 adcroft 1.1 iG = myXGlobalLo-1+(bi-1)*sNx
187     jG = myYGlobalLo-1+(bj-1)*sNy
188     irec = 1 + int(iG/sNx) + (jG/sNy)*nSx*nPx +
189     & (irecord-1)*nSx*nPx*nSy*nPy
190 jmc 1.13 ELSE
191 adcroft 1.1 iG = 0
192     jG = 0
193     irec = irecord
194 jmc 1.13 ENDIF
195     IF ( arrType.EQ.'RS' ) THEN
196     CALL MDS_RD_REC_RS( arr, xy_buffer_r4, xy_buffer_r8,
197     I filePrec, dUnit, irec, narr, myThid )
198     ELSEIF ( arrType.EQ.'RL' ) THEN
199     CALL MDS_RD_REC_RL( arr, xy_buffer_r4, xy_buffer_r8,
200     I filePrec, dUnit, irec, narr, myThid )
201     ELSE
202     WRITE(msgBuf,'(A)')
203     & ' MDSREADVECTOR: illegal value for arrType'
204     CALL PRINT_ERROR( msgBuf, myThid )
205     STOP 'ABNORMAL END: S/R MDSREADVECTOR'
206     ENDIF
207     IF (.NOT. globalFile) THEN
208     CLOSE( dUnit )
209 adcroft 1.1 fileIsOpen = .FALSE.
210 jmc 1.13 ENDIF
211     ENDIF
212 adcroft 1.1 C End of bi,bj loops
213 jmc 1.13 c ENDDO
214     c ENDDO
215 adcroft 1.1
216     C If global file was opened then close it
217 jmc 1.13 IF (fileIsOpen .AND. globalFile) THEN
218     CLOSE( dUnit )
219 adcroft 1.1 fileIsOpen = .FALSE.
220 jmc 1.13 ENDIF
221 adcroft 1.1
222     _END_MASTER( myThid )
223    
224 jmc 1.13 ENDIF
225     C end-if ( .not. useSingleCPUIO )
226 heimbach 1.6
227    
228 adcroft 1.1 C ------------------------------------------------------------------
229 heimbach 1.6
230    
231 jmc 1.13 IF ( useSingleCPUIO ) THEN
232 heimbach 1.6
233     C master thread of process 0, only, opens a global file
234     _BEGIN_MASTER( myThid )
235     #ifdef ALLOW_USE_MPI
236     IF( mpiMyId .EQ. 0 ) THEN
237     #else
238     IF ( .TRUE. ) THEN
239     #endif /* ALLOW_USE_MPI */
240    
241     C Check first for global file with simple name (ie. fName)
242     dataFName = fName
243 jmc 1.13 INQUIRE( file=dataFName, exist=exst )
244     IF (exst) globalFile = .TRUE.
245 heimbach 1.6
246     C If negative check for global file with MDS name (ie. fName.data)
247 jmc 1.13 IF (.NOT. globalFile) THEN
248     WRITE(dataFName,'(2a)') fName(1:IL),'.data'
249     INQUIRE( file=dataFName, exist=exst )
250     IF (exst) globalFile = .TRUE.
251     ENDIF
252 heimbach 1.6
253     C If global file is visible to process 0, then open it here.
254     C Otherwise stop program.
255 jmc 1.13 IF ( globalFile) THEN
256     length_of_rec=MDS_RECLEN( filePrec, vec_size, myThid )
257     OPEN( dUnit, file=dataFName, status='old',
258 heimbach 1.6 & access='direct', recl=length_of_rec )
259 jmc 1.13 ELSE
260     WRITE(msgBuf,'(2A)')
261     & ' MDSREADVECTOR: filename: ',dataFName(1:IL)
262     C-jmc: why double print (stdout + stderr) ?
263     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
264     & SQUEEZE_RIGHT , myThid )
265     CALL PRINT_ERROR( msgBuf, myThid )
266     WRITE(msgBuf,'(A)')
267     & ' MDSREADVECTOR: File does not exist'
268     CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
269     & SQUEEZE_RIGHT , myThid )
270     CALL PRINT_ERROR( msgBuf, myThid )
271     STOP 'ABNORMAL END: S/R MDSREADVECTOR'
272     ENDIF
273 heimbach 1.6
274     ENDIF
275     _END_MASTER( myThid )
276    
277     DO k=1,1
278    
279     _BEGIN_MASTER( myThid )
280     #ifdef ALLOW_USE_MPI
281     IF( mpiMyId .EQ. 0 ) THEN
282     #else
283     IF ( .TRUE. ) THEN
284     #endif /* ALLOW_USE_MPI */
285     irec = irecord
286 jmc 1.13 IF (filePrec .EQ. precFloat32) THEN
287     READ(dUnit,rec=irec) xy_buffer_r4
288 heimbach 1.6 #ifdef _BYTESWAPIO
289 jmc 1.13 CALL MDS_BYTESWAPR4( vec_size, xy_buffer_r4 )
290 heimbach 1.6 #endif
291 heimbach 1.11 cph#if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)
292 heimbach 1.6 c
293 heimbach 1.11 cph#else /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */
294 heimbach 1.6 DO L=1,narr*nPx*nPy
295     global(L) = xy_buffer_r4(L)
296     ENDDO
297 heimbach 1.11 cph#endif /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */
298 jmc 1.13 ELSEIF (filePrec .EQ. precFloat64) THEN
299     READ(dUnit,rec=irec) xy_buffer_r8
300 heimbach 1.6 #ifdef _BYTESWAPIO
301 jmc 1.13 CALL MDS_BYTESWAPR8( vec_size, xy_buffer_r8 )
302 heimbach 1.6 #endif
303 heimbach 1.11 cph#if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO)
304 heimbach 1.6 c
305 heimbach 1.11 cph#else /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */
306 heimbach 1.6 DO L=1,narr*nPx*nPy
307     global(L) = xy_buffer_r8(L)
308     ENDDO
309 heimbach 1.11 cph#endif /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */
310 jmc 1.13 ELSE
311     WRITE(msgBuf,'(A)')
312     & ' MDSREADVECTOR: illegal value for filePrec'
313     CALL PRINT_ERROR( msgBuf, myThid )
314     STOP 'ABNORMAL END: S/R MDSREADVECTOR'
315     ENDIF
316 heimbach 1.6 ENDIF
317     _END_MASTER( myThid )
318 jmc 1.13 CALL SCATTER_VECTOR( narr,global,local,myThid )
319     IF ( arrType.EQ.'RS' ) THEN
320     CALL MDS_BUFFERtoRS( local, arr, narr, .TRUE., myThid )
321     ELSEIF ( arrType.EQ.'RL' ) THEN
322     CALL MDS_BUFFERtoRL( local, arr, narr, .TRUE., myThid )
323     ELSE
324     WRITE(msgBuf,'(A)')
325     & ' MDSREADVECTOR: illegal value for arrType'
326     CALL PRINT_ERROR( msgBuf, myThid )
327     STOP 'ABNORMAL END: S/R MDSREADVECTOR'
328     ENDIF
329 heimbach 1.6
330     ENDDO
331 jmc 1.13 C end-do k=1,1
332 heimbach 1.6
333     _BEGIN_MASTER( myThid )
334 jmc 1.13 CLOSE( dUnit )
335 heimbach 1.6 _END_MASTER( myThid )
336    
337 jmc 1.13 ENDIF
338     C end-if ( useSingleCPUIO )
339 heimbach 1.6
340 jmc 1.15 #else /* ALLOW_AUTODIFF */
341     STOP 'ABNORMAL END: S/R MDSREADVECTOR is empty'
342 jmc 1.14 #endif /* ALLOW_AUTODIFF */
343 jahn 1.12
344 jmc 1.13 RETURN
345     END

  ViewVC Help
Powered by ViewVC 1.1.22