1 |
C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_writevector.F,v 1.13 2009/08/02 20:42:43 jmc Exp $ |
2 |
C $Name: $ |
3 |
|
4 |
#include "MDSIO_OPTIONS.h" |
5 |
|
6 |
SUBROUTINE MDSWRITEVECTOR( |
7 |
I fName, |
8 |
I filePrec, |
9 |
I globalfile, |
10 |
I arrType, |
11 |
I narr, |
12 |
I arr, |
13 |
I bi, |
14 |
I bj, |
15 |
I irecord, |
16 |
I myIter, |
17 |
I myThid ) |
18 |
|
19 |
C Arguments: |
20 |
C |
21 |
C fName string :: base name for file to written |
22 |
C filePrec integer :: number of bits per word in file (32 or 64) |
23 |
C globalFile logical :: selects between writing a global or tiled file |
24 |
C arrType char(2) :: declaration of "arr": either "RS" or "RL" |
25 |
C narr integer :: size of third dimension: normally either 1 or Nr |
26 |
C arr RS/RL :: array to write, arr(narr) |
27 |
C bi integer :: x tile index |
28 |
C bj integer :: y tile index |
29 |
C irecord integer :: record number to read |
30 |
C myIter integer :: time step number |
31 |
C myThid integer :: thread identifier |
32 |
C |
33 |
C Created: 03/26/99 eckert@mit.edu |
34 |
C Modified: 03/29/99 adcroft@mit.edu + eckert@mit.edu |
35 |
C Fixed to work work with _RS and _RL declarations |
36 |
C Modified: 07/27/99 eckert@mit.edu |
37 |
C Customized for state estimation (--> active_file_control.F) |
38 |
C Changed: 05/31/00 heimbach@mit.edu |
39 |
C open(dUnit, ..., status='old', ... -> status='unknown' |
40 |
|
41 |
IMPLICIT NONE |
42 |
C Global variables / common blocks |
43 |
#include "SIZE.h" |
44 |
#include "EEPARAMS.h" |
45 |
#include "PARAMS.h" |
46 |
#include "EESUPPORT.h" |
47 |
|
48 |
C Routine arguments |
49 |
CHARACTER*(*) fName |
50 |
INTEGER filePrec |
51 |
LOGICAL globalfile |
52 |
CHARACTER*(2) arrType |
53 |
INTEGER narr |
54 |
_RL arr(narr) |
55 |
INTEGER bi,bj |
56 |
INTEGER irecord |
57 |
INTEGER myIter |
58 |
INTEGER myThid |
59 |
|
60 |
#ifdef ALLOW_AUTODIFF |
61 |
|
62 |
C Functions |
63 |
INTEGER ILNBLNK |
64 |
INTEGER MDS_RECLEN |
65 |
EXTERNAL ILNBLNK |
66 |
EXTERNAL MDS_RECLEN |
67 |
C Local variables |
68 |
CHARACTER*(MAX_LEN_FNAM) dataFName,metaFName,pfName |
69 |
INTEGER iG,jG,irec,dUnit,IL,pIL |
70 |
LOGICAL fileIsOpen |
71 |
INTEGER dimList(3,3), nDims, map2gl(2) |
72 |
INTEGER length_of_rec |
73 |
CHARACTER*(MAX_LEN_MBUF) msgBuf |
74 |
|
75 |
cph( |
76 |
cph Deal with useSingleCpuIO |
77 |
cph Not implemented here for EXCH2 |
78 |
INTEGER vec_size |
79 |
#ifdef ALLOW_USE_MPI |
80 |
LOGICAL lprint |
81 |
INTEGER K,L |
82 |
c INTEGER iG_IO,jG_IO,npe |
83 |
Real*8 global(narr*nPx*nPy) |
84 |
_RL local(narr) |
85 |
#endif |
86 |
cph) |
87 |
Real*4 xy_buffer_r4(narr*nPx*nPy) |
88 |
Real*8 xy_buffer_r8(narr*nPx*nPy) |
89 |
_RL dummyRL(1) |
90 |
CHARACTER*8 blank8c |
91 |
|
92 |
DATA dummyRL(1) / 0. _d 0 / |
93 |
DATA blank8c / ' ' / |
94 |
DATA map2gl / 0, 1 / |
95 |
|
96 |
C ------------------------------------------------------------------ |
97 |
|
98 |
vec_size = narr*nPx*nPy |
99 |
|
100 |
C Only do I/O if I am the master thread |
101 |
_BEGIN_MASTER( myThid ) |
102 |
|
103 |
C Record number must be >= 1 |
104 |
IF (irecord .LT. 1) THEN |
105 |
WRITE(msgBuf,'(A,I9.8)') |
106 |
& ' MDSWRITEVECTOR: argument irecord = ',irecord |
107 |
CALL PRINT_ERROR( msgBuf, myThid ) |
108 |
WRITE(msgBuf,'(A)') |
109 |
& ' MDSWRITEVECTOR: invalid value for irecord' |
110 |
CALL PRINT_ERROR( msgBuf, myThid ) |
111 |
STOP 'ABNORMAL END: S/R MDSWRITEVECTOR' |
112 |
ENDIF |
113 |
|
114 |
C Assume nothing |
115 |
fileIsOpen = .FALSE. |
116 |
IL = ILNBLNK( fName ) |
117 |
pIL = ILNBLNK( mdsioLocalDir ) |
118 |
|
119 |
C Assign special directory |
120 |
IF ( mdsioLocalDir .NE. ' ' ) THEN |
121 |
WRITE(pfName,'(2A)') |
122 |
& mdsioLocalDir(1:pIL), fName(1:IL) |
123 |
ELSE |
124 |
pfName= fName |
125 |
ENDIF |
126 |
pIL=ILNBLNK( pfName ) |
127 |
|
128 |
C Assign a free unit number as the I/O channel for this routine |
129 |
CALL MDSFINDUNIT( dUnit, myThid ) |
130 |
|
131 |
#ifdef ALLOW_USE_MPI |
132 |
_END_MASTER( myThid ) |
133 |
C If option globalFile is desired but does not work or if |
134 |
C globalFile is too slow, then try using single-CPU I/O. |
135 |
IF (useSingleCpuIO) THEN |
136 |
|
137 |
C Master thread of process 0, only, opens a global file |
138 |
_BEGIN_MASTER( myThid ) |
139 |
IF( mpiMyId .EQ. 0 ) THEN |
140 |
WRITE(dataFName,'(2a)') fName(1:IL),'.data' |
141 |
length_of_rec=MDS_RECLEN(filePrec,vec_size,myThid) |
142 |
IF (irecord .EQ. 1) THEN |
143 |
OPEN( dUnit, file=dataFName, status=_NEW_STATUS, |
144 |
& access='direct', recl=length_of_rec ) |
145 |
ELSE |
146 |
OPEN( dUnit, file=dataFName, status=_OLD_STATUS, |
147 |
& access='direct', recl=length_of_rec ) |
148 |
ENDIF |
149 |
ENDIF |
150 |
_END_MASTER( myThid ) |
151 |
|
152 |
C Gather array and write it to file, one vertical level at a time |
153 |
DO k=1,1 |
154 |
IF ( arrType.EQ.'RS' ) THEN |
155 |
CALL MDS_BUFFERtoRS( local, arr, narr, .FALSE., myThid ) |
156 |
ELSEIF ( arrType.EQ.'RL' ) THEN |
157 |
CALL MDS_BUFFERtoRL( local, arr, narr, .FALSE., myThid ) |
158 |
ELSE |
159 |
WRITE(msgBuf,'(A)') |
160 |
& ' MDSWRITEVECTOR: illegal value for arrType' |
161 |
CALL PRINT_ERROR( msgBuf, myThid ) |
162 |
STOP 'ABNORMAL END: S/R MDSWRITEVECTOR' |
163 |
ENDIF |
164 |
cph( |
165 |
cph IF ( irecord .EQ. 1 .AND. fName(1:IL) .EQ. |
166 |
cph & 'tapelev2_7_the_main_loop_theta.it0000' ) THEN |
167 |
cph lprint = .TRUE. |
168 |
cph ELSE |
169 |
lprint = .FALSE. |
170 |
cph ENDIF |
171 |
cph) |
172 |
CALL GATHER_VECTOR( lprint, narr, global, local, myThid ) |
173 |
_BEGIN_MASTER( myThid ) |
174 |
IF( mpiMyId .EQ. 0 ) THEN |
175 |
irec=irecord |
176 |
IF (filePrec .EQ. precFloat32) THEN |
177 |
cph#if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) |
178 |
c |
179 |
cph#else /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */ |
180 |
DO L=1,narr*nPx*nPy |
181 |
xy_buffer_r4(L) = global(L) |
182 |
ENDDO |
183 |
cph#endif /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */ |
184 |
#ifdef _BYTESWAPIO |
185 |
CALL MDS_BYTESWAPR4( vec_size, xy_buffer_r4 ) |
186 |
#endif |
187 |
WRITE(dUnit,rec=irec) xy_buffer_r4 |
188 |
ELSEIF (filePrec .EQ. precFloat64) THEN |
189 |
cph#if defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) |
190 |
c |
191 |
cph#else /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */ |
192 |
DO L=1,narr*nPx*nPy |
193 |
xy_buffer_r8(L) = global(L) |
194 |
ENDDO |
195 |
cph#endif /* defined(ALLOW_EXCH2) && !defined(MISSING_TILE_IO) */ |
196 |
#ifdef _BYTESWAPIO |
197 |
CALL MDS_BYTESWAPR8( vec_size, xy_buffer_r8 ) |
198 |
#endif |
199 |
WRITE(dUnit,rec=irec) xy_buffer_r8 |
200 |
ELSE |
201 |
WRITE(msgBuf,'(A)') |
202 |
& ' MDSWRITEVECTOR: illegal value for filePrec' |
203 |
CALL PRINT_ERROR( msgBuf, myThid ) |
204 |
STOP 'ABNORMAL END: S/R MDSWRITEVECTOR' |
205 |
ENDIF |
206 |
ENDIF |
207 |
_END_MASTER( myThid ) |
208 |
C End k loop |
209 |
ENDDO |
210 |
|
211 |
C Close data-file and create meta-file |
212 |
_BEGIN_MASTER( myThid ) |
213 |
IF( mpiMyId .EQ. 0 ) THEN |
214 |
CLOSE( dUnit ) |
215 |
WRITE(metaFName,'(2a)') fName(1:IL),'.meta' |
216 |
dimList(1,1)=vec_size |
217 |
dimList(2,1)=1 |
218 |
dimList(3,1)=vec_size |
219 |
dimList(1,2)=vec_size |
220 |
dimList(2,2)=1 |
221 |
dimList(3,2)=vec_size |
222 |
dimList(1,3)=1 |
223 |
dimList(2,3)=1 |
224 |
dimList(3,3)=1 |
225 |
nDims = 1 |
226 |
CALL MDS_WRITE_META( |
227 |
I metaFName, dataFName, the_run_name, ' ', |
228 |
I filePrec, nDims, dimList, map2gl, 0, blank8c, |
229 |
I 0, dummyRL, irecord, myIter, myThid ) |
230 |
ENDIF |
231 |
_END_MASTER( myThid ) |
232 |
C To be safe, make other processes wait for I/O completion |
233 |
_BARRIER |
234 |
|
235 |
ELSEIF ( .NOT. useSingleCpuIO ) THEN |
236 |
_BEGIN_MASTER( myThid ) |
237 |
#endif /* ALLOW_USE_MPI */ |
238 |
|
239 |
C If we are writing to a global file then we open it here |
240 |
IF (globalFile) THEN |
241 |
WRITE(dataFName,'(2A)') fName(1:IL),'.data' |
242 |
IF (irecord .EQ. 1) THEN |
243 |
length_of_rec = MDS_RECLEN( filePrec, narr, myThid ) |
244 |
OPEN( dUnit, file=dataFName, status=_NEW_STATUS, |
245 |
& access='direct', recl=length_of_rec ) |
246 |
fileIsOpen=.TRUE. |
247 |
ELSE |
248 |
length_of_rec = MDS_RECLEN( filePrec, narr, myThid ) |
249 |
OPEN( dUnit, file=dataFName, status=_OLD_STATUS, |
250 |
& access='direct', recl=length_of_rec ) |
251 |
fileIsOpen=.TRUE. |
252 |
ENDIF |
253 |
ENDIF |
254 |
|
255 |
C Loop over all tiles |
256 |
c DO bj=1,nSy |
257 |
c DO bi=1,nSx |
258 |
C If we are writing to a tiled MDS file then we open each one here |
259 |
IF (.NOT. globalFile) THEN |
260 |
iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles |
261 |
jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles |
262 |
WRITE(dataFName,'(2A,I3.3,A,I3.3,A)') |
263 |
& pfName(1:pIL),'.',iG,'.',jG,'.data' |
264 |
IF (irecord .EQ. 1) THEN |
265 |
length_of_rec = MDS_RECLEN( filePrec, narr, myThid ) |
266 |
OPEN( dUnit, file=dataFName, status=_NEW_STATUS, |
267 |
& access='direct', recl=length_of_rec ) |
268 |
fileIsOpen=.TRUE. |
269 |
ELSE |
270 |
length_of_rec = MDS_RECLEN( filePrec, narr, myThid ) |
271 |
OPEN( dUnit, file=dataFName, status=_OLD_STATUS, |
272 |
& access='direct', recl=length_of_rec ) |
273 |
fileIsOpen=.TRUE. |
274 |
ENDIF |
275 |
ENDIF |
276 |
IF (fileIsOpen) THEN |
277 |
IF (globalFile) THEN |
278 |
iG = myXGlobalLo-1+(bi-1)*sNx |
279 |
jG = myYGlobalLo-1+(bj-1)*sNy |
280 |
irec = 1 + int(iG/sNx) + (jG/sNy)*nSx*nPx + |
281 |
& (irecord-1)*nSx*nPx*nSy*nPy |
282 |
ELSE |
283 |
iG = 0 |
284 |
jG = 0 |
285 |
irec = irecord |
286 |
ENDIF |
287 |
IF ( arrType.EQ.'RS' ) THEN |
288 |
CALL MDS_WR_REC_RS( arr, xy_buffer_r4, xy_buffer_r8, |
289 |
I filePrec, dUnit, irec, narr, myThid ) |
290 |
ELSEIF ( arrType.EQ.'RL' ) THEN |
291 |
CALL MDS_WR_REC_RL( arr, xy_buffer_r4, xy_buffer_r8, |
292 |
I filePrec, dUnit, irec, narr, myThid ) |
293 |
ELSE |
294 |
WRITE(msgBuf,'(A)') |
295 |
& ' MDSWRITEVECTOR: illegal value for arrType' |
296 |
CALL PRINT_ERROR( msgBuf, myThid ) |
297 |
STOP 'ABNORMAL END: S/R MDSWRITEVECTOR' |
298 |
ENDIF |
299 |
ELSE |
300 |
WRITE(msgBuf,'(A)') |
301 |
& ' MDSWRITEVECTOR: I should never get to this point' |
302 |
CALL PRINT_ERROR( msgBuf, myThid ) |
303 |
STOP 'ABNORMAL END: S/R MDSWRITEVECTOR' |
304 |
ENDIF |
305 |
C If we were writing to a tiled MDS file then we close it here |
306 |
IF (fileIsOpen .AND. (.NOT. globalFile)) THEN |
307 |
CLOSE( dUnit ) |
308 |
fileIsOpen = .FALSE. |
309 |
ENDIF |
310 |
C Create meta-file for each tile file |
311 |
IF (.NOT. globalFile) THEN |
312 |
iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles |
313 |
jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles |
314 |
WRITE(metaFName,'(2a,i3.3,a,i3.3,a)') |
315 |
& pfName(1:pIL),'.',iG,'.',jG,'.meta' |
316 |
dimList(1,1) = nPx*nSx*narr |
317 |
dimList(2,1) = ((myXGlobalLo-1)/sNx + (bi-1))*narr + 1 |
318 |
dimList(3,1) = ((myXGlobalLo-1)/sNx + bi )*narr |
319 |
dimList(1,2) = nPy*nSy |
320 |
dimList(2,2) = (myYGlobalLo-1)/sNy + bj |
321 |
dimList(3,2) = (myYGlobalLo-1)/sNy + bj |
322 |
dimList(1,3) = 1 |
323 |
dimList(2,3) = 1 |
324 |
dimList(3,3) = 1 |
325 |
nDims = 1 |
326 |
CALL MDS_WRITE_META( |
327 |
I metaFName, dataFName, the_run_name, ' ', |
328 |
I filePrec, nDims, dimList, map2gl, 0, blank8c, |
329 |
I 0, dummyRL, irecord, myIter, myThid ) |
330 |
ENDIF |
331 |
C End of bi,bj loops |
332 |
c ENDDO |
333 |
c ENDDO |
334 |
|
335 |
C If global file was opened then close it |
336 |
IF (fileIsOpen .AND. globalFile) THEN |
337 |
CLOSE( dUnit ) |
338 |
fileIsOpen = .FALSE. |
339 |
ENDIF |
340 |
|
341 |
C Create meta-file for global file |
342 |
IF (globalFile) THEN |
343 |
WRITE(metaFName,'(2A)') fName(1:IL),'.meta' |
344 |
dimList(1,1) = nPx*nSx*narr |
345 |
dimList(2,1) = 1 |
346 |
dimList(3,1) = nPx*nSx*narr |
347 |
dimList(1,2) = nPy*nSy |
348 |
dimList(2,2) = 1 |
349 |
dimList(3,2) = nPy*nSy |
350 |
dimList(1,3) = 1 |
351 |
dimList(2,3) = 1 |
352 |
dimList(3,3) = 1 |
353 |
nDims = 1 |
354 |
CALL MDS_WRITE_META( |
355 |
I metaFName, dataFName, the_run_name, ' ', |
356 |
I filePrec, nDims, dimList, map2gl, 0, blank8c, |
357 |
I 0, dummyRL, irecord, myIter, myThid ) |
358 |
c I metaFName, dataFName, the_run_name, titleLine, |
359 |
c I filePrec, nDims, dimList, map2gl, nFlds, fldList, |
360 |
c I nTimRec, timList, irecord, myIter, myThid ) |
361 |
ENDIF |
362 |
|
363 |
_END_MASTER( myThid ) |
364 |
|
365 |
#ifdef ALLOW_USE_MPI |
366 |
C End-if useSingleCpuIO |
367 |
ENDIF |
368 |
#endif /* ALLOW_USE_MPI */ |
369 |
|
370 |
#else /* ALLOW_AUTODIFF */ |
371 |
STOP 'ABNORMAL END: S/R MDSWRITEVECTOR is empty' |
372 |
#endif /* ALLOW_AUTODIFF */ |
373 |
|
374 |
C ------------------------------------------------------------------ |
375 |
RETURN |
376 |
END |