/[MITgcm]/MITgcm/eesupp/src/mdsio.F
ViewVC logotype

Contents of /MITgcm/eesupp/src/mdsio.F

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

Revision 1.9 - (show annotations) (download)
Sun Feb 4 14:38:43 2001 UTC (24 years, 9 months ago) by cnh
Branch: MAIN
CVS Tags: checkpoint46n_post, checkpoint51k_post, ecco_c44_e18, checkpoint47j_post, ecco_c44_e16, checkpoint40pre1, checkpoint36, checkpoint48d_pre, checkpoint44b_post, checkpoint51j_post, branch-exfmods-tag, checkpoint35, checkpoint47e_post, checkpoint43a-release1mods, checkpoint44h_pre, checkpoint47i_post, ecco_c44_e19, checkpoint52e_pre, release1_p12, release1_p13, release1_p10, release1_p11, release1_p16, release1_p17, release1_p14, release1_p15, ecco_c44_e17, pre38tag1, checkpoint47f_post, checkpoint40pre9, checkpoint47c_post, checkpoint50e_post, checkpoint52e_post, checkpoint50c_post, checkpoint46i_post, checkpoint51n_pre, checkpoint47d_post, ecco_c44_e21, ecco_c44_e26, ecco_c44_e27, ecco_c44_e24, ecco_c44_e25, icebear5, icebear4, checkpoint44f_pre, checkpoint47a_post, icebear3, icebear2, checkpoint46f_post, checkpoint52d_pre, ecco_c50_e33a, checkpoint46d_pre, release1_p13_pre, checkpoint48e_post, checkpoint46e_post, checkpoint48d_post, checkpoint50g_post, release1-branch_tutorials, checkpoint46c_post, checkpoint44g_post, branchpoint-genmake2, checkpoint44h_post, release1_p12_pre, checkpoint44e_post, checkpoint46k_post, ecco-branch-mod1, checkpoint46e_pre, ecco-branch-mod4, ecco-branch-mod5, branch-netcdf, checkpoint48f_post, checkpoint45d_post, checkpoint51r_post, checkpoint52b_pre, checkpoint46l_post, checkpoint51o_pre, checkpoint46j_pre, checkpoint45b_post, checkpoint46b_pre, checkpoint51i_post, checkpoint46j_post, checkpoint48c_post, chkpt44a_pre, release1-branch-end, c37_adj, release1_final_v1, checkpoint51e_post, checkpoint51b_post, checkpoint46, ecco_c50_e28, checkpoint51l_pre, checkpoint51c_post, ecco_c50_e32, ecco_c50_e33, ecco_c50_e30, ecco_c50_e31, checkpoint47d_pre, checkpoint47, checkpoint44, checkpoint45, checkpoint48, checkpoint49, checkpoint44f_post, checkpoint47b_post, checkpoint40pre2, checkpoint40pre5, checkpoint51l_post, checkpoint40pre6, checkpoint48i_post, checkpoint51o_post, checkpoint40pre8, checkpoint46l_pre, checkpoint51f_pre, release1_b1, checkpoint48h_post, checkpoint51q_post, checkpoint50d_pre, ecco_c51_e34, chkpt44d_post, ecco_c50_e29, checkpoint42, release1_p9, checkpoint46h_pre, checkpoint51, checkpoint50, checkpoint47h_post, checkpoint52, release1_p8, checkpoint50d_post, checkpoint52d_post, checkpoint46g_pre, release1_p2, release1_p3, release1_p4, checkpoint51b_pre, release1_p6, checkpoint52a_post, checkpoint46a_post, checkpoint47g_post, checkpoint52b_post, chkpt44a_post, checkpoint52f_post, checkpoint44b_pre, checkpoint52c_post, release1_p1, checkpoint46m_post, checkpoint48a_post, checkpoint40pre4, checkpoint51h_pre, checkpoint46a_pre, ecco_c51_e34e, checkpoint40pre3, checkpoint50c_pre, checkpoint45c_post, checkpoint50b_pre, release1_p5, checkpoint44e_pre, checkpoint51g_post, ecco_c52_e35, release1_p7, ecco_ice2, ecco_ice1, checkpoint46b_post, checkpoint51f_post, pre38-close, checkpoint46d_post, ecco-branch-mod2, checkpoint48b_post, checkpoint50b_post, checkpoint46g_post, checkpoint45a_post, ecco_c51_e34d, ecco_c51_e34f, ecco_c51_e34g, ecco_c51_e34a, ecco_c51_e34b, ecco_c51_e34c, checkpoint50f_post, checkpoint50a_post, checkpoint46c_pre, checkpoint50f_pre, checkpoint52a_pre, ecco-branch-mod3, checkpoint43, checkpoint51d_post, checkpoint37, checkpoint40, checkpoint48c_pre, release1-branch_branchpoint, ecco_c44_e22, release1_beta1, ecco_c44_e23, checkpoint51m_post, checkpoint51t_post, ecco_c44_e20, checkpoint40pre7, checkpoint50h_post, checkpoint52i_post, checkpoint51a_post, checkpoint39, checkpoint46h_post, checkpoint50e_pre, checkpoint38, checkpoint50i_post, checkpoint51p_post, checkpoint51n_post, release1_chkpt44d_post, checkpoint48g_post, checkpoint51i_pre, chkpt44c_pre, checkpoint52i_pre, checkpoint51u_post, checkpoint52h_pre, checkpoint52f_pre, hrcube_1, hrcube_2, checkpoint41, checkpoint51s_post, chkpt44c_post
Branch point for: c24_e25_ice, netcdf-sm0, ecco-branch, release1_final, branch-genmake2, pre38, release1, branch-exfmods-curt, release1_coupled, branch-nonh, icebear, tg2-branch, checkpoint51n_branch, release1-branch, release1_50yr
Changes since 1.8: +2 -1 lines 
Made sure each .F and .h file had
the CVS keywords Header and Name at its start.
Most had header but very few currently have Name, so
lots of changes!
1 C $Header: /u/gcmpack/models/MITgcmUV/eesupp/src/mdsio.F,v 1.8 2000/11/13 16:18:21 heimbach Exp $
2 C $Name: $
3
4 #include "CPP_OPTIONS.h"
5
6 C The five "public" routines supplied here are:
7 C
8 C MDSREADFIELD - read model field from direct access global or tiled MDS file
9 C MDSWRITEFIELD - write model field to direct access global or tiled MDS file
10 C MDSFINDUNIT - returns an available (unused) I/O channel
11 C MDSREADVECTOR - read vector from direct access global or tiled MDS file
12 C MDSWRITEVECTOR - write vector to direct access global or tiled MDS file
13 C
14 C all other routines are "private" to these utilities and ought
15 C not be accessed directly from the main code.
16 C
17 C Created: 03/16/99 adcroft@mit.edu
18 C Modified: 03/23/99 adcroft@mit.edu
19 C To work with multiple records
20 C Modified: 03/29/99 eckert@mit.edu
21 C Added arbitrary vector capability
22 C Modified: 07/27/99 eckert@mit.edu
23 C Customized for state estimation (--> active_file_control.F)
24 C this relates only to *mdsreadvector* and *mdswritevector*
25 C Modified: 07/28/99 eckert@mit.edu
26 C inserted calls to *print_message* and *print_error*
27 C
28 C To be modified to work with MITgcmuv message routines.
29
30 #undef SAFE_IO
31
32 #ifdef SAFE_IO
33 #define _NEW_STATUS 'new'
34 #else
35 #define _NEW_STATUS 'unknown'
36 #endif
37
38 #ifdef ALLOW_AUTODIFF_TAMC
39 #define _OLD_STATUS 'unknown'
40 #else
41 #define _OLD_STATUS 'old'
42 #endif
43
44
45 C=======================================================================
46 SUBROUTINE MDSREADFIELD(
47 I fName,
48 I filePrec,
49 I arrType,
50 I nNz,
51 O arr,
52 I irecord,
53 I myThid )
54 C
55 C Arguments:
56 C
57 C fName string base name for file to read
58 C filePrec integer number of bits per word in file (32 or 64)
59 C arrType char(2) declaration of "arr": either "RS" or "RL"
60 C nNz integer size of third dimension: normally either 1 or Nr
61 C arr RS/RL array to read into, arr(:,:,nNz,:,:)
62 C irecord integer record number to read
63 C myThid integer thread identifier
64 C
65 C MDSREADFIELD first checks to see if the file "fName" exists, then
66 C if the file "fName.data" exists and finally the tiled files of the
67 C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
68 C read because it is difficult to parse files in fortran.
69 C The precision of the file is decsribed by filePrec, set either
70 C to floatPrec32 or floatPrec64. The precision or declaration of
71 C the array argument must be consistently described by the char*(2)
72 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
73 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
74 C nNz=Nr implies a 3-D model field. irecord is the record number
75 C to be read and must be >= 1. The file data is stored in
76 C arr *but* the overlaps are *not* updated. ie. An exchange must
77 C be called. This is because the routine is sometimes called from
78 C within a MASTER_THID region.
79 C
80 C Created: 03/16/99 adcroft@mit.edu
81
82 implicit none
83 C Global variables / common blocks
84 #include "SIZE.h"
85 #include "EEPARAMS.h"
86 #include "PARAMS.h"
87
88 C Routine arguments
89 character*(*) fName
90 integer filePrec
91 character*(2) arrType
92 integer nNz
93 Real arr(*)
94 integer irecord
95 integer myThid
96 C Functions
97 integer ILNBLNK
98 integer MDS_RECLEN
99 C Local variables
100 character*(80) dataFName
101 integer iG,jG,irec,bi,bj,j,k,dUnit,IL
102 logical exst
103 Real*4 r4seg(sNx)
104 Real*8 r8seg(sNx)
105 logical globalFile,fileIsOpen
106 integer length_of_rec
107 character*(max_len_mbuf) msgbuf
108 C ------------------------------------------------------------------
109
110 C Only do I/O if I am the master thread
111 _BEGIN_MASTER( myThid )
112
113 C Record number must be >= 1
114 if (irecord .LT. 1) then
115 write(msgbuf,'(a,i9.8)')
116 & ' MDSREADFIELD: argument irecord = ',irecord
117 call print_message( msgbuf, standardmessageunit,
118 & SQUEEZE_RIGHT , mythid)
119 write(msgbuf,'(a)')
120 & ' MDSREADFIELD: Invalid value for irecord'
121 call print_error( msgbuf, mythid )
122 stop 'ABNORMAL END: S/R MDSREADFIELD'
123 endif
124
125 C Assume nothing
126 globalFile = .FALSE.
127 fileIsOpen = .FALSE.
128 IL=ILNBLNK( fName )
129
130 C Assign a free unit number as the I/O channel for this routine
131 call MDSFINDUNIT( dUnit, mythid )
132
133 C Check first for global file with simple name (ie. fName)
134 dataFName = fName
135 inquire( file=dataFname, exist=exst )
136 if (exst) then
137 write(msgbuf,'(a,a)')
138 & ' MDSREADFIELD: opening global file: ',dataFName
139 call print_message( msgbuf, standardmessageunit,
140 & SQUEEZE_RIGHT , mythid)
141 globalFile = .TRUE.
142 endif
143
144 C If negative check for global file with MDS name (ie. fName.data)
145 if (.NOT. globalFile) then
146 write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
147 inquire( file=dataFname, exist=exst )
148 if (exst) then
149 write(msgbuf,'(a,a)')
150 & ' MDSREADFIELD: opening global file: ',dataFName
151 call print_message( msgbuf, standardmessageunit,
152 & SQUEEZE_RIGHT , mythid)
153 globalFile = .TRUE.
154 endif
155 endif
156
157 C If we are reading from a global file then we open it here
158 if (globalFile) then
159 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
160 open( dUnit, file=dataFName, status='old',
161 & access='direct', recl=length_of_rec )
162 fileIsOpen=.TRUE.
163 endif
164
165 C Loop over all tiles
166 do bj=1,nSy
167 do bi=1,nSx
168 C If we are reading from a tiled MDS file then we open each one here
169 if (.NOT. globalFile) then
170 iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
171 jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
172 write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
173 & fName(1:IL),'.',iG,'.',jG,'.data'
174 inquire( file=dataFname, exist=exst )
175 C Of course, we only open the file if the tile is "active"
176 C (This is a place-holder for the active/passive mechanism
177 if (exst) then
178 write(msgbuf,'(a,a)')
179 & ' MDSREADFIELD: opening file: ',dataFName
180 call print_message( msgbuf, standardmessageunit,
181 & SQUEEZE_RIGHT , mythid)
182 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
183 open( dUnit, file=dataFName, status='old',
184 & access='direct', recl=length_of_rec )
185 fileIsOpen=.TRUE.
186 else
187 fileIsOpen=.FALSE.
188 write(msgbuf,'(a,a)')
189 & ' MDSREADFIELD: filename: ',dataFName
190 call print_message( msgbuf, standardmessageunit,
191 & SQUEEZE_RIGHT , mythid)
192 write(msgbuf,'(a)')
193 & ' MDSREADFIELD: File does not exist'
194 call print_error( msgbuf, mythid )
195 stop 'ABNORMAL END: S/R MDSREADFIELD'
196 endif
197 endif
198
199 if (fileIsOpen) then
200 do k=1,nNz
201 do j=1,sNy
202 if (globalFile) then
203 iG = myXGlobalLo-1 + (bi-1)*sNx
204 jG = myYGlobalLo-1 + (bj-1)*sNy
205 irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
206 & + nSx*nPx*Ny*nNz*(irecord-1)
207 else
208 iG = 0
209 jG = 0
210 irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)
211 endif
212 if (filePrec .eq. precFloat32) then
213 read(dUnit,rec=irec) r4seg
214 #ifdef _BYTESWAPIO
215 call MDS_BYTESWAPR4( sNx, r4seg )
216 #endif
217 if (arrType .eq. 'RS') then
218 call MDS_SEG4toRS( j,bi,bj,k,nNz, r4seg, .TRUE., arr )
219 elseif (arrType .eq. 'RL') then
220 call MDS_SEG4toRL( j,bi,bj,k,nNz, r4seg, .TRUE., arr )
221 else
222 write(msgbuf,'(a)')
223 & ' MDSREADFIELD: illegal value for arrType'
224 call print_error( msgbuf, mythid )
225 stop 'ABNORMAL END: S/R MDSREADFIELD'
226 endif
227 elseif (filePrec .eq. precFloat64) then
228 read(dUnit,rec=irec) r8seg
229 #ifdef _BYTESWAPIO
230 call MDS_BYTESWAPR8( sNx, r8seg )
231 #endif
232 if (arrType .eq. 'RS') then
233 call MDS_SEG8toRS( j,bi,bj,k,nNz, r8seg, .TRUE., arr )
234 elseif (arrType .eq. 'RL') then
235 call MDS_SEG8toRL( j,bi,bj,k,nNz, r8seg, .TRUE., arr )
236 else
237 write(msgbuf,'(a)')
238 & ' MDSREADFIELD: illegal value for arrType'
239 call print_error( msgbuf, mythid )
240 stop 'ABNORMAL END: S/R MDSREADFIELD'
241 endif
242 else
243 write(msgbuf,'(a)')
244 & ' MDSREADFIELD: illegal value for filePrec'
245 call print_error( msgbuf, mythid )
246 stop 'ABNORMAL END: S/R MDSREADFIELD'
247 endif
248 C End of j loop
249 enddo
250 C End of k loop
251 enddo
252 if (.NOT. globalFile) then
253 close( dUnit )
254 fileIsOpen = .FALSE.
255 endif
256 endif
257 C End of bi,bj loops
258 enddo
259 enddo
260
261 C If global file was opened then close it
262 if (fileIsOpen .AND. globalFile) then
263 close( dUnit )
264 fileIsOpen = .FALSE.
265 endif
266
267 _END_MASTER( myThid )
268
269 C ------------------------------------------------------------------
270 return
271 end
272 C=======================================================================
273
274 C=======================================================================
275 SUBROUTINE MDSWRITEFIELD(
276 I fName,
277 I filePrec,
278 I globalFile,
279 I arrType,
280 I nNz,
281 I arr,
282 I irecord,
283 I myIter,
284 I myThid )
285 C
286 C Arguments:
287 C
288 C fName string base name for file to written
289 C filePrec integer number of bits per word in file (32 or 64)
290 C globalFile logical selects between writing a global or tiled file
291 C arrType char(2) declaration of "arr": either "RS" or "RL"
292 C nNz integer size of third dimension: normally either 1 or Nr
293 C arr RS/RL array to write, arr(:,:,nNz,:,:)
294 C irecord integer record number to read
295 C myIter integer time step number
296 C myThid integer thread identifier
297 C
298 C MDSWRITEFIELD creates either a file of the form "fName.data" and
299 C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
300 C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
301 C "fName.xxx.yyy.meta". A meta-file is always created.
302 C Currently, the meta-files are not read because it is difficult
303 C to parse files in fortran. We should read meta information before
304 C adding records to an existing multi-record file.
305 C The precision of the file is decsribed by filePrec, set either
306 C to floatPrec32 or floatPrec64. The precision or declaration of
307 C the array argument must be consistently described by the char*(2)
308 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
309 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
310 C nNz=Nr implies a 3-D model field. irecord is the record number
311 C to be read and must be >= 1. NOTE: It is currently assumed that
312 C the highest record number in the file was the last record written.
313 C Nor is there a consistency check between the routine arguments and file.
314 C ie. if your write record 2 after record 4 the meta information
315 C will record the number of records to be 2. This, again, is because
316 C we have read the meta information. To be fixed.
317 C
318 C Created: 03/16/99 adcroft@mit.edu
319 C
320 C Changed: 05/31/00 heimbach@mit.edu
321 C open(dUnit, ..., status='old', ... -> status='unknown'
322
323 implicit none
324 C Global variables / common blocks
325 #include "SIZE.h"
326 #include "EEPARAMS.h"
327 #include "PARAMS.h"
328
329 C Routine arguments
330 character*(*) fName
331 integer filePrec
332 logical globalFile
333 character*(2) arrType
334 integer nNz
335 cph(
336 cph Real arr(*)
337 _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nNz,nSx,nSy)
338 cph)
339 integer irecord
340 integer myIter
341 integer myThid
342 C Functions
343 integer ILNBLNK
344 integer MDS_RECLEN
345 C Local variables
346 character*(80) dataFName,metaFName
347 integer iG,jG,irec,bi,bj,j,k,dUnit,IL
348 Real*4 r4seg(sNx)
349 Real*8 r8seg(sNx)
350 integer dimList(3,3),ndims
351 integer length_of_rec
352 logical fileIsOpen
353 character*(max_len_mbuf) msgbuf
354 C ------------------------------------------------------------------
355
356 C Only do I/O if I am the master thread
357 _BEGIN_MASTER( myThid )
358
359 C Record number must be >= 1
360 if (irecord .LT. 1) then
361 write(msgbuf,'(a,i9.8)')
362 & ' MDSWRITEFIELD: argument irecord = ',irecord
363 call print_message( msgbuf, standardmessageunit,
364 & SQUEEZE_RIGHT , mythid)
365 write(msgbuf,'(a)')
366 & ' MDSWRITEFIELD: invalid value for irecord'
367 call print_error( msgbuf, mythid )
368 stop 'ABNORMAL END: S/R MDSWRITEFIELD'
369 endif
370
371 C Assume nothing
372 fileIsOpen=.FALSE.
373 IL=ILNBLNK( fName )
374
375 C Assign a free unit number as the I/O channel for this routine
376 call MDSFINDUNIT( dUnit, mythid )
377
378 C If we are writing to a global file then we open it here
379 if (globalFile) then
380 write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
381 if (irecord .EQ. 1) then
382 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
383 open( dUnit, file=dataFName, status=_NEW_STATUS,
384 & access='direct', recl=length_of_rec )
385 fileIsOpen=.TRUE.
386 else
387 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
388 open( dUnit, file=dataFName, status=_OLD_STATUS,
389 & access='direct', recl=length_of_rec )
390 fileIsOpen=.TRUE.
391 endif
392 endif
393
394 C Loop over all tiles
395 do bj=1,nSy
396 do bi=1,nSx
397 C If we are writing to a tiled MDS file then we open each one here
398 if (.NOT. globalFile) then
399 iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
400 jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
401 write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
402 & fName(1:IL),'.',iG,'.',jG,'.data'
403 if (irecord .EQ. 1) then
404 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
405 open( dUnit, file=dataFName, status=_NEW_STATUS,
406 & access='direct', recl=length_of_rec )
407 fileIsOpen=.TRUE.
408 else
409 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
410 open( dUnit, file=dataFName, status=_OLD_STATUS,
411 & access='direct', recl=length_of_rec )
412 fileIsOpen=.TRUE.
413 endif
414 endif
415 if (fileIsOpen) then
416 do k=1,nNz
417 do j=1,sNy
418 if (globalFile) then
419 iG = myXGlobalLo-1+(bi-1)*sNx
420 jG = myYGlobalLo-1+(bj-1)*sNy
421 irec=1+INT(iG/sNx)+nSx*nPx*(jG+j-1)+nSx*nPx*Ny*(k-1)
422 & +nSx*nPx*Ny*nNz*(irecord-1)
423 else
424 iG = 0
425 jG = 0
426 irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)
427 endif
428 if (filePrec .eq. precFloat32) then
429 if (arrType .eq. 'RS') then
430 call MDS_SEG4toRS( j,bi,bj,k,nNz, r4seg, .FALSE., arr )
431 elseif (arrType .eq. 'RL') then
432 call MDS_SEG4toRL( j,bi,bj,k,nNz, r4seg, .FALSE., arr )
433 else
434 write(msgbuf,'(a)')
435 & ' MDSWRITEFIELD: illegal value for arrType'
436 call print_error( msgbuf, mythid )
437 stop 'ABNORMAL END: S/R MDSWRITEFIELD'
438 endif
439 #ifdef _BYTESWAPIO
440 call MDS_BYTESWAPR4( sNx, r4seg )
441 #endif
442 write(dUnit,rec=irec) r4seg
443 elseif (filePrec .eq. precFloat64) then
444 if (arrType .eq. 'RS') then
445 call MDS_SEG8toRS( j,bi,bj,k,nNz, r8seg, .FALSE., arr )
446 elseif (arrType .eq. 'RL') then
447 call MDS_SEG8toRL( j,bi,bj,k,nNz, r8seg, .FALSE., arr )
448 else
449 write(msgbuf,'(a)')
450 & ' MDSWRITEFIELD: illegal value for arrType'
451 call print_error( msgbuf, mythid )
452 stop 'ABNORMAL END: S/R MDSWRITEFIELD'
453 endif
454 #ifdef _BYTESWAPIO
455 call MDS_BYTESWAPR8( sNx, r8seg )
456 #endif
457 write(dUnit,rec=irec) r8seg
458 else
459 write(msgbuf,'(a)')
460 & ' MDSWRITEFIELD: illegal value for filePrec'
461 call print_error( msgbuf, mythid )
462 stop 'ABNORMAL END: S/R MDSWRITEFIELD'
463 endif
464 C End of j loop
465 enddo
466 C End of k loop
467 enddo
468 else
469 write(msgbuf,'(a)')
470 & ' MDSWRITEFIELD: I should never get to this point'
471 call print_error( msgbuf, mythid )
472 stop 'ABNORMAL END: S/R MDSWRITEFIELD'
473 endif
474 C If we were writing to a tiled MDS file then we close it here
475 if (fileIsOpen .AND. (.NOT. globalFile)) then
476 close( dUnit )
477 fileIsOpen = .FALSE.
478 endif
479 C Create meta-file for each tile if we are tiling
480 if (.NOT. globalFile) then
481 iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
482 jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
483 write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
484 & fName(1:IL),'.',iG,'.',jG,'.meta'
485 dimList(1,1)=Nx
486 dimList(2,1)=myXGlobalLo+(bi-1)*sNx
487 dimList(3,1)=myXGlobalLo+bi*sNx-1
488 dimList(1,2)=Ny
489 dimList(2,2)=myYGlobalLo+(bj-1)*sNy
490 dimList(3,2)=myYGlobalLo+bj*sNy-1
491 dimList(1,3)=Nr
492 dimList(2,3)=1
493 dimList(3,3)=Nr
494 ndims=3
495 if (nNz .EQ. 1) ndims=2
496 call MDSWRITEMETA( metaFName, dataFName,
497 & filePrec, ndims, dimList, irecord, myIter, mythid )
498 endif
499 C End of bi,bj loops
500 enddo
501 enddo
502
503 C If global file was opened then close it
504 if (fileIsOpen .AND. globalFile) then
505 close( dUnit )
506 fileIsOpen = .FALSE.
507 endif
508
509 C Create meta-file for the global-file
510 if (globalFile) then
511 C We can not do this operation using threads (yet) because of the
512 C "barrier" at the next step. The barrier could be removed but
513 C at the cost of "safe" distributed I/O.
514 if (nThreads.NE.1) then
515 write(msgbuf,'(a,a)')
516 & ' MDSWRITEFIELD: A threads version of this routine',
517 & ' does not exist.'
518 call print_message( msgbuf, standardmessageunit,
519 & SQUEEZE_RIGHT , mythid)
520 write(msgbuf,'(a)')
521 & ' MDSWRITEFIELD: This needs to be fixed...'
522 call print_message( msgbuf, standardmessageunit,
523 & SQUEEZE_RIGHT , mythid)
524 write(msgbuf,'(a,i3.2)')
525 & ' MDSWRITEFIELD: nThreads = ',nThreads
526 call print_message( msgbuf, standardmessageunit,
527 & SQUEEZE_RIGHT , mythid)
528 write(msgbuf,'(a)')
529 & ' MDSWRITEFIELD: Stopping because you are using threads'
530 call print_error( msgbuf, mythid )
531 stop 'ABNORMAL END: S/R MDSWRITEFIELD'
532 endif
533 C We put a barrier here to ensure that all processes have finished
534 C writing their data before we update the meta-file
535 _BARRIER
536 write(metaFName(1:80),'(2a)') fName(1:IL),'.meta'
537 dimList(1,1)=Nx
538 dimList(2,1)=1
539 dimList(3,1)=Nx
540 dimList(1,2)=Ny
541 dimList(2,2)=1
542 dimList(3,2)=Ny
543 dimList(1,3)=Nr
544 dimList(2,3)=1
545 dimList(3,3)=Nr
546 ndims=3
547 if (nNz .EQ. 1) ndims=2
548 call MDSWRITEMETA( metaFName, dataFName,
549 & filePrec, ndims, dimList, irecord, myIter, mythid )
550 fileIsOpen=.TRUE.
551 endif
552
553 _END_MASTER( myThid )
554
555 C ------------------------------------------------------------------
556 return
557 end
558 C=======================================================================
559
560 C=======================================================================
561 subroutine MDS_SEG4toRS( j,bi,bj,k,nNz, seg, copyTo, arr )
562 C IN:
563 C j,bi,bj,k integer - indices to array "arr"
564 C nNz integer - K dimension of array "arr"
565 C seg Real*4 - 1-D vector of length sNx
566 C OUT:
567 C arr _RS - model tiled array
568 C
569 C Created: 03/20/99 adcroft@mit.edu
570
571 implicit none
572 C Global variables / common blocks
573 #include "SIZE.h"
574
575 C Arguments
576 integer j,bi,bj,k,nNz
577 _RS arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nNz,nSx,nSy)
578 logical copyTo
579 Real*4 seg(sNx)
580 C Local
581 integer ii
582
583 C ------------------------------------------------------------------
584
585 if (copyTo) then
586 do ii=1,sNx
587 arr(ii,j,k,bi,bj)=seg(ii)
588 enddo
589 else
590 do ii=1,sNx
591 seg(ii)=arr(ii,j,k,bi,bj)
592 enddo
593 endif
594
595 C ------------------------------------------------------------------
596 return
597 end
598 C=======================================================================
599
600 C=======================================================================
601 subroutine MDS_SEG4toRL( j,bi,bj,k,nNz, seg, copyTo, arr )
602 C IN:
603 C j,bi,bj,k integer - indices to array "arr"
604 C nNz integer - K dimension of array "arr"
605 C seg Real*4 - 1-D vector of length sNx
606 C OUT:
607 C arr _RL - model tiled array
608 C
609 C Created: 03/20/99 adcroft@mit.edu
610
611 implicit none
612 C Global variables / common blocks
613 #include "SIZE.h"
614
615 C Arguments
616 integer j,bi,bj,k,nNz
617 _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nNz,nSx,nSy)
618 logical copyTo
619 Real*4 seg(sNx)
620 C Local
621 integer ii
622 C ------------------------------------------------------------------
623 if (copyTo) then
624 do ii=1,sNx
625 arr(ii,j,k,bi,bj)=seg(ii)
626 enddo
627 else
628 do ii=1,sNx
629 seg(ii)=arr(ii,j,k,bi,bj)
630 enddo
631 endif
632 C ------------------------------------------------------------------
633 return
634 end
635 C=======================================================================
636
637 C=======================================================================
638 subroutine MDS_SEG8toRS( j,bi,bj,k,nNz, seg, copyTo, arr )
639 C IN:
640 C j,bi,bj,k integer - indices to array "arr"
641 C nNz integer - K dimension of array "arr"
642 C seg Real*8 - 1-D vector of length sNx
643 C OUT:
644 C arr _RS - model tiled array
645 C
646 C Created: 03/20/99 adcroft@mit.edu
647
648 implicit none
649 C Global variables / common blocks
650 #include "SIZE.h"
651
652 C Arguments
653 integer j,bi,bj,k,nNz
654 _RS arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nNz,nSx,nSy)
655 logical copyTo
656 Real*8 seg(sNx)
657 C Local
658 integer ii
659 C ------------------------------------------------------------------
660 if (copyTo) then
661 do ii=1,sNx
662 arr(ii,j,k,bi,bj)=seg(ii)
663 enddo
664 else
665 do ii=1,sNx
666 seg(ii)=arr(ii,j,k,bi,bj)
667 enddo
668 endif
669 C ------------------------------------------------------------------
670 return
671 end
672 C=======================================================================
673
674 C=======================================================================
675 subroutine MDS_SEG8toRL( j,bi,bj,k,nNz, seg, copyTo, arr )
676 C IN:
677 C j,bi,bj,k integer - indices to array "arr"
678 C nNz integer - K dimension of array "arr"
679 C seg Real*8 - 1-D vector of length sNx
680 C OUT:
681 C arr _RL - model tiled array
682 C
683 C Created: 03/20/99 adcroft@mit.edu
684
685 implicit none
686 C Global variables / common blocks
687 #include "SIZE.h"
688
689 C Arguments
690 integer j,bi,bj,k,nNz
691 _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nNz,nSx,nSy)
692 logical copyTo
693 Real*8 seg(sNx)
694 C Local
695 integer ii
696 C ------------------------------------------------------------------
697 if (copyTo) then
698 do ii=1,sNx
699 arr(ii,j,k,bi,bj)=seg(ii)
700 enddo
701 else
702 do ii=1,sNx
703 seg(ii)=arr(ii,j,k,bi,bj)
704 enddo
705 endif
706 C ------------------------------------------------------------------
707 return
708 end
709 C=======================================================================
710
711 C=======================================================================
712 subroutine MDSWRITEMETA(
713 I mFileName,
714 I dFileName,
715 I filePrec,
716 I ndims,
717 I dimList,
718 I nrecords,
719 I myIter,
720 I mythid )
721
722 C IN:
723 C mFileName string - complete name of meta-file
724 C dFileName string - complete name of data-file
725 C ndims integer - number of dimensions
726 C dimList integer - array of dimensions, etc.
727 C nrecords integer - record number
728 C myIter integer - time-step number
729 C mythid integer - thread id
730 C OUT:
731 C
732 C Created: 03/20/99 adcroft@mit.edu
733
734 implicit none
735 C Arguments
736 character*(*) mFileName
737 character*(*) dFileName
738 integer filePrec
739 integer ndims
740 integer dimList(3,ndims)
741 integer nrecords
742 integer myIter
743 integer mythid
744
745 C Global variables / common blocks
746 #include "SIZE.h"
747 #include "EEPARAMS.h"
748 #include "PARAMS.h"
749
750 C Functions
751
752 C Local
753 integer i,ii,mUnit
754 logical ex
755 character*(max_len_mbuf) msgbuf
756 C ------------------------------------------------------------------
757
758 C We should *read* the met-file if it exists to check
759 C that the information we are writing is consistent
760 C with the current contents
761 inquire( file=mFileName, exist=ex )
762 C However, it is bloody difficult to parse files
763 C in fortran so someone else can do this.
764 C For now, we will assume everything is ok
765 C and that the last record is written to the
766 C last consecutive record in the file.
767
768 C Assign a free unit number as the I/O channel for this subroutine
769 call MDSFINDUNIT( mUnit, mythid )
770
771 C Open meta-file
772 open( mUnit, file=mFileName, status='unknown',
773 & form='formatted' )
774
775 C Write the number of dimensions
776 write(mUnit,'(x,a,i3,a)') 'nDims = [ ',ndims,' ];'
777
778 C For each dimension, write the following:
779 C 1 global size (ie. the size of the global dimension of all files)
780 C 2 global start (ie. the global position of the start of this file)
781 C 3 global end (ie. the global position of the end of this file)
782
783 write(mUnit,'(x,a)') 'dimList = ['
784 do ii=1,ndims
785 if (ii.lt.ndims) then
786 write(mUnit,'(10x,3(i5,","))') (dimList(i,ii),i=1,3)
787 else
788 write(mUnit,'(10x,i5,",",i5,",",i5)') (dimList(i,ii),i=1,3)
789 endif
790 enddo
791 write(mUnit,'(10x,a)') '];'
792
793 C Record the precision of the file
794 if (filePrec .EQ. precFloat32) then
795 write(mUnit,'(x,a)') "format = [ 'float32' ];"
796 elseif (filePrec .EQ. precFloat64) then
797 write(mUnit,'(x,a)') "format = [ 'float64' ];"
798 else
799 write(msgbuf,'(a)')
800 & ' MDSWRITEMETA: invalid filePrec'
801 call print_error( msgbuf, mythid )
802 stop 'ABNORMAL END: S/R MDSWRITEMETA'
803 endif
804
805 C Record the current record number
806 C This is a proxy for the actual number of records in the file.
807 C If we could read the file then we could do this properly.
808 write(mUnit,'(x,a,i5,a)') 'nrecords = [ ',nrecords,' ];'
809
810 C Record the file-name for the binary data
811 Cveto ii=ILNBLNK( dFileName )
812 Cveto write(mUnit,'(x,3a)') 'binarydatafile = [ ',dFileName(1:ii),' ];'
813
814 C Write the integer time (integer iteration number) for later record
815 C keeping. If the timestep number is less than 0 then we assume
816 C that the information is superfluous and do not write it.
817 if (myIter .ge. 0)
818 & write(mUnit,'(x,a,i8,a)') 'timeStepNumber = [ ',myIter,' ];'
819
820 C Close meta-file
821 close(mUnit)
822
823 C ------------------------------------------------------------------
824 return
825 end
826 C=======================================================================
827
828 C=======================================================================
829 subroutine MDSFINDUNIT( iounit, mythid )
830 C OUT:
831 C iounit integer - unit number
832 C
833 C MDSFINDUNIT returns a valid, unused unit number for f77 I/O
834 C The routine stops the program is an error occurs in the process
835 C of searching the I/O channels.
836 C
837 C Created: 03/20/99 adcroft@mit.edu
838
839 implicit none
840
841 #include "EEPARAMS.h"
842
843 C Arguments
844 integer iounit
845 integer mythid
846 C Local
847 integer ii
848 logical op
849 integer ios
850 character*(max_len_mbuf) msgbuf
851 C ------------------------------------------------------------------
852
853 C Sweep through a valid range of unit numbers
854 iounit=-1
855 do ii=9,99
856 if (iounit.eq.-1) then
857 inquire(unit=ii,iostat=ios,opened=op)
858 if (ios.ne.0) then
859 write(msgbuf,'(a,i2.2)')
860 & ' MDSFINDUNIT: inquiring unit number = ',ii
861 call print_message( msgbuf, standardmessageunit,
862 & SQUEEZE_RIGHT , mythid)
863 write(msgbuf,'(a)')
864 & ' MDSFINDUNIT: inquire statement failed!'
865 call print_error( msgbuf, mythid )
866 stop 'ABNORMAL END: S/R MDSFINDUNIT'
867 endif
868 if (.NOT. op) then
869 iounit=ii
870 endif
871 endif
872 enddo
873
874 C Was there an available unit number
875 if (iounit.eq.-1) then
876 write(msgbuf,'(a)')
877 & ' MDSFINDUNIT: could not find an available unit number!'
878 call print_error( msgbuf, mythid )
879 stop 'ABNORMAL END: S/R MDSFINDUNIT'
880 endif
881
882 C ------------------------------------------------------------------
883 return
884 end
885 C=======================================================================
886
887 C=======================================================================
888 integer function MDS_RECLEN( filePrec, nnn, mythid )
889 C IN:
890 C filePrec integer - precision of file in bits
891 C nnn integer - number of elements in record
892 C OUT:
893 C MDS_RECLEN integer - appropriate length of record in bytes or words
894 C
895 C Created: 03/29/99 eckert@mit.edu + adcroft@mit.edu
896
897 implicit none
898 C Arguments
899 integer filePrec
900 integer nnn
901 integer mythid
902 C Global variables
903 #include "SIZE.h"
904 #include "EEPARAMS.h"
905 #include "PARAMS.h"
906 C Local
907 character*(max_len_mbuf) msgbuf
908 C ------------------------------------------------------------------
909
910 if (filePrec .EQ. precFloat32) then
911 MDS_RECLEN=nnn*WORDLENGTH
912 elseif (filePrec .EQ. precFloat64) then
913 MDS_RECLEN=nnn*WORDLENGTH*2
914 else
915 write(msgbuf,'(a,i2.2)')
916 & ' MDS_RECLEN: filePrec = ',filePrec
917 call print_message( msgbuf, standardmessageunit,
918 & SQUEEZE_RIGHT , mythid)
919 write(msgbuf,'(a)')
920 & ' MDS_RECLEN: illegal value for filePrec'
921 call print_error( msgbuf, mythid )
922 stop 'ABNORMAL END: S/R MDS_RECLEN'
923 endif
924
925 C ------------------------------------------------------------------
926 return
927 end
928 C=======================================================================
929
930 C=======================================================================
931 SUBROUTINE MDSREADVECTOR(
932 I fName,
933 I filePrec,
934 I arrType,
935 I narr,
936 O arr,
937 I bi,
938 I bj,
939 I irecord,
940 I myThid )
941 C
942 C Arguments:
943 C
944 C fName string base name for file to read
945 C filePrec integer number of bits per word in file (32 or 64)
946 C arrType char(2) declaration of "arr": either "RS" or "RL"
947 C narr integer size of third dimension: normally either 1 or Nr
948 C arr RS/RL array to read into, arr(narr)
949 ce bi integer x tile index
950 ce bj integer y tile index
951 C irecord integer record number to read
952 C myThid integer thread identifier
953 C
954 C Created: 03/26/99 eckert@mit.edu
955 C Modified: 03/29/99 adcroft@mit.edu + eckert@mit.edu
956 C Fixed to work work with _RS and _RL declarations
957 C Modified: 07/27/99 eckert@mit.edu
958 C Customized for state estimation (--> active_file_control.F)
959
960 implicit none
961 C Global variables / common blocks
962 #include "SIZE.h"
963 #include "EEPARAMS.h"
964 #include "PARAMS.h"
965
966 C Routine arguments
967 character*(*) fName
968 integer filePrec
969 character*(2) arrType
970 integer narr
971 Real arr(narr)
972 integer irecord
973 integer myThid
974 ce
975 integer bi,bj
976 ce
977
978 C Functions
979 integer ILNBLNK
980 integer MDS_RECLEN
981 C Local variables
982 character*(80) dataFName
983 integer iG,jG,irec,dUnit,IL
984 logical exst
985 logical globalFile,fileIsOpen
986 integer length_of_rec
987 character*(max_len_mbuf) msgbuf
988 C ------------------------------------------------------------------
989
990 C Only do I/O if I am the master thread
991 _BEGIN_MASTER( myThid )
992
993 C Record number must be >= 1
994 if (irecord .LT. 1) then
995 write(msgbuf,'(a,i9.8)')
996 & ' MDSREADVECTOR: argument irecord = ',irecord
997 call print_message( msgbuf, standardmessageunit,
998 & SQUEEZE_RIGHT , mythid)
999 write(msgbuf,'(a)')
1000 & ' MDSREADVECTOR: invalid value for irecord'
1001 call print_error( msgbuf, mythid )
1002 stop 'ABNORMAL END: S/R MDSREADVECTOR'
1003 endif
1004
1005 C Assume nothing
1006 globalFile = .FALSE.
1007 fileIsOpen = .FALSE.
1008 IL=ILNBLNK( fName )
1009
1010 C Assign a free unit number as the I/O channel for this routine
1011 call MDSFINDUNIT( dUnit, mythid )
1012
1013 C Check first for global file with simple name (ie. fName)
1014 dataFName = fName
1015 inquire( file=dataFname, exist=exst )
1016 if (exst) then
1017 write(msgbuf,'(a,a)')
1018 & ' MDSREADVECTOR: opening global file: ',dataFName
1019 call print_message( msgbuf, standardmessageunit,
1020 & SQUEEZE_RIGHT , mythid)
1021 globalFile = .TRUE.
1022 endif
1023
1024 C If negative check for global file with MDS name (ie. fName.data)
1025 if (.NOT. globalFile) then
1026 write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
1027 inquire( file=dataFname, exist=exst )
1028 if (exst) then
1029 write(msgbuf,'(a,a)')
1030 & ' MDSREADVECTOR: opening global file: ',dataFName
1031 call print_message( msgbuf, standardmessageunit,
1032 & SQUEEZE_RIGHT , mythid)
1033 globalFile = .TRUE.
1034 endif
1035 endif
1036
1037 C If we are reading from a global file then we open it here
1038 if (globalFile) then
1039 length_of_rec=MDS_RECLEN( filePrec, narr, mythid )
1040 open( dUnit, file=dataFName, status='old',
1041 & access='direct', recl=length_of_rec )
1042 fileIsOpen=.TRUE.
1043 endif
1044
1045 C Loop over all tiles
1046 ce do bj=1,nSy
1047 ce do bi=1,nSx
1048 C If we are reading from a tiled MDS file then we open each one here
1049 if (.NOT. globalFile) then
1050 iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
1051 jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
1052 write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
1053 & fName(1:IL),'.',iG,'.',jG,'.data'
1054 inquire( file=dataFname, exist=exst )
1055 C Of course, we only open the file if the tile is "active"
1056 C (This is a place-holder for the active/passive mechanism)
1057 if (exst) then
1058 write(msgbuf,'(a,a)')
1059 & ' MDSREADVECTOR: opening file: ',dataFName
1060 call print_message( msgbuf, standardmessageunit,
1061 & SQUEEZE_RIGHT , mythid)
1062 length_of_rec=MDS_RECLEN( filePrec, narr, mythid )
1063 open( dUnit, file=dataFName, status='old',
1064 & access='direct', recl=length_of_rec )
1065 fileIsOpen=.TRUE.
1066 else
1067 fileIsOpen=.FALSE.
1068 write(msgbuf,'(a)')
1069 & ' MDSREADVECTOR: un-active tiles not implemented yet'
1070 call print_error( msgbuf, mythid )
1071 stop 'ABNORMAL END: S/R MDSREADVECTOR'
1072 endif
1073 endif
1074 if (fileIsOpen) then
1075 if (globalFile) then
1076 iG = myXGlobalLo-1+(bi-1)*sNx
1077 jG = myYGlobalLo-1+(bj-1)*sNy
1078 irec = 1 + int(iG/sNx) + (jG/sNy)*nSx*nPx +
1079 & (irecord-1)*nSx*nPx*nSy*nPy
1080 else
1081 iG = 0
1082 jG = 0
1083 irec = irecord
1084 endif
1085 if (filePrec .eq. precFloat32) then
1086 call MDS_READ_RS_VEC( dUnit, irec, narr, arr, myThid )
1087 elseif (filePrec .eq. precFloat64) then
1088 call MDS_READ_RL_VEC( dUnit, irec, narr, arr, myThid )
1089 else
1090 write(msgbuf,'(a)')
1091 & ' MDSREADVECTOR: illegal value for filePrec'
1092 call print_error( msgbuf, mythid )
1093 stop 'ABNORMAL END: S/R MDSREADVECTOR'
1094 endif
1095 if (.NOT. globalFile) then
1096 close( dUnit )
1097 fileIsOpen = .FALSE.
1098 endif
1099 endif
1100 C End of bi,bj loops
1101 ce enddo
1102 ce enddo
1103
1104 C If global file was opened then close it
1105 if (fileIsOpen .AND. globalFile) then
1106 close( dUnit )
1107 fileIsOpen = .FALSE.
1108 endif
1109
1110 _END_MASTER( myThid )
1111
1112 C ------------------------------------------------------------------
1113 return
1114 end
1115 C=======================================================================
1116
1117 C=======================================================================
1118 SUBROUTINE MDSWRITEVECTOR(
1119 I fName,
1120 I filePrec,
1121 I globalfile,
1122 I arrType,
1123 I narr,
1124 I arr,
1125 I bi,
1126 I bj,
1127 I irecord,
1128 I myIter,
1129 I myThid )
1130 C Arguments:
1131 C
1132 C fName string base name for file to written
1133 C filePrec integer number of bits per word in file (32 or 64)
1134 C globalFile logical selects between writing a global or tiled file
1135 C arrType char(2) declaration of "arr": either "RS" or "RL"
1136 C narr integer size of third dimension: normally either 1 or Nr
1137 C arr RS/RL array to write, arr(narr)
1138 ce bi integer x tile index
1139 ce bj integer y tile index
1140 C irecord integer record number to read
1141 C myIter integer time step number
1142 C myThid integer thread identifier
1143 C
1144 C Created: 03/26/99 eckert@mit.edu
1145 C Modified: 03/29/99 adcroft@mit.edu + eckert@mit.edu
1146 C Fixed to work work with _RS and _RL declarations
1147 C Modified: 07/27/99 eckert@mit.edu
1148 C Customized for state estimation (--> active_file_control.F)
1149 C Changed: 05/31/00 heimbach@mit.edu
1150 C open(dUnit, ..., status='old', ... -> status='unknown'
1151
1152 implicit none
1153 C Global variables / common blocks
1154 #include "SIZE.h"
1155 #include "EEPARAMS.h"
1156 #include "PARAMS.h"
1157
1158 C Routine arguments
1159 character*(*) fName
1160 integer filePrec
1161 logical globalfile
1162 character*(2) arrType
1163 integer narr
1164 Real arr(narr)
1165 integer irecord
1166 integer myIter
1167 integer myThid
1168 ce
1169 integer bi,bj
1170 ce
1171
1172 C Functions
1173 integer ILNBLNK
1174 integer MDS_RECLEN
1175 C Local variables
1176 character*(80) dataFName,metaFName
1177 integer iG,jG,irec,dUnit,IL
1178 logical fileIsOpen
1179 integer dimList(3,3),ndims
1180 integer length_of_rec
1181 character*(max_len_mbuf) msgbuf
1182 C ------------------------------------------------------------------
1183
1184 C Only do I/O if I am the master thread
1185 _BEGIN_MASTER( myThid )
1186
1187 C Record number must be >= 1
1188 if (irecord .LT. 1) then
1189 write(msgbuf,'(a,i9.8)')
1190 & ' MDSWRITEVECTOR: argument irecord = ',irecord
1191 call print_message( msgbuf, standardmessageunit,
1192 & SQUEEZE_RIGHT , mythid)
1193 write(msgbuf,'(a)')
1194 & ' MDSWRITEVECTOR: invalid value for irecord'
1195 call print_error( msgbuf, mythid )
1196 stop 'ABNORMAL END: S/R MDSWRITEVECTOR'
1197 endif
1198
1199 C Assume nothing
1200 fileIsOpen = .FALSE.
1201 IL=ILNBLNK( fName )
1202
1203 C Assign a free unit number as the I/O channel for this routine
1204 call MDSFINDUNIT( dUnit, mythid )
1205
1206 C If we are writing to a global file then we open it here
1207 if (globalFile) then
1208 write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
1209 if (irecord .EQ. 1) then
1210 length_of_rec = MDS_RECLEN( filePrec, narr, mythid )
1211 open( dUnit, file=dataFName, status=_NEW_STATUS,
1212 & access='direct', recl=length_of_rec )
1213 fileIsOpen=.TRUE.
1214 else
1215 length_of_rec = MDS_RECLEN( filePrec, narr, mythid )
1216 open( dUnit, file=dataFName, status=_OLD_STATUS,
1217 & access='direct', recl=length_of_rec )
1218 fileIsOpen=.TRUE.
1219 endif
1220 endif
1221
1222 C Loop over all tiles
1223 ce do bj=1,nSy
1224 ce do bi=1,nSx
1225 C If we are writing to a tiled MDS file then we open each one here
1226 if (.NOT. globalFile) then
1227 iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
1228 jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
1229 write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
1230 & fName(1:IL),'.',iG,'.',jG,'.data'
1231 if (irecord .EQ. 1) then
1232 length_of_rec = MDS_RECLEN( filePrec, narr, mythid )
1233 open( dUnit, file=dataFName, status=_NEW_STATUS,
1234 & access='direct', recl=length_of_rec )
1235 fileIsOpen=.TRUE.
1236 else
1237 length_of_rec = MDS_RECLEN( filePrec, narr, mythid )
1238 open( dUnit, file=dataFName, status=_OLD_STATUS,
1239 & access='direct', recl=length_of_rec )
1240 fileIsOpen=.TRUE.
1241 endif
1242 endif
1243 if (fileIsOpen) then
1244 if (globalFile) then
1245 iG = myXGlobalLo-1+(bi-1)*sNx
1246 jG = myYGlobalLo-1+(bj-1)*sNy
1247 irec = 1 + int(iG/sNx) + (jG/sNy)*nSx*nPx +
1248 & (irecord-1)*nSx*nPx*nSy*nPy
1249 else
1250 iG = 0
1251 jG = 0
1252 irec = irecord
1253 endif
1254 if (filePrec .eq. precFloat32) then
1255 call MDS_WRITE_RS_VEC( dUnit, irec, narr, arr, myThid )
1256 elseif (filePrec .eq. precFloat64) then
1257 call MDS_WRITE_RL_VEC( dUnit, irec, narr, arr, myThid )
1258 else
1259 write(msgbuf,'(a)')
1260 & ' MDSWRITEVECTOR: illegal value for filePrec'
1261 call print_error( msgbuf, mythid )
1262 stop 'ABNORMAL END: S/R MDSWRITEVECTOR'
1263 endif
1264 else
1265 write(msgbuf,'(a)')
1266 & ' MDSWRITEVECTOR: I should never get to this point'
1267 call print_error( msgbuf, mythid )
1268 stop 'ABNORMAL END: S/R MDSWRITEVECTOR'
1269 endif
1270 C If we were writing to a tiled MDS file then we close it here
1271 if (fileIsOpen .AND. (.NOT. globalFile)) then
1272 close( dUnit )
1273 fileIsOpen = .FALSE.
1274 endif
1275 C Create meta-file for each tile file
1276 if (.NOT. globalFile) then
1277 iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
1278 jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
1279 write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
1280 & fName(1:IL),'.',iG,'.',jG,'.meta'
1281 dimList(1,1) = nPx*nSx*narr
1282 dimList(2,1) = ((myXGlobalLo-1)/sNx + (bi-1))*narr + 1
1283 dimList(3,1) = ((myXGlobalLo-1)/sNx + bi )*narr
1284 dimList(1,2) = nPy*nSy
1285 dimList(2,2) = (myYGlobalLo-1)/sNy + bj
1286 dimList(3,2) = (myYGlobalLo-1)/sNy + bj
1287 dimList(1,3) = 1
1288 dimList(2,3) = 1
1289 dimList(3,3) = 1
1290 ndims=1
1291 call MDSWRITEMETA( metaFName, dataFName,
1292 & filePrec, ndims, dimList, irecord, myIter, mythid )
1293 endif
1294 C End of bi,bj loops
1295 ce enddo
1296 ce enddo
1297
1298 C If global file was opened then close it
1299 if (fileIsOpen .AND. globalFile) then
1300 close( dUnit )
1301 fileIsOpen = .FALSE.
1302 endif
1303
1304 C Create meta-file for global file
1305 if (globalFile) then
1306 write(metaFName(1:80),'(2a)') fName(1:IL),'.meta'
1307 dimList(1,1) = nPx*nSx*narr
1308 dimList(2,1) = 1
1309 dimList(3,1) = nPx*nSx*narr
1310 dimList(1,2) = nPy*nSy
1311 dimList(2,2) = 1
1312 dimList(3,2) = nPy*nSy
1313 dimList(1,3) = 1
1314 dimList(2,3) = 1
1315 dimList(3,3) = 1
1316 ndims=1
1317 call MDSWRITEMETA( metaFName, dataFName,
1318 & filePrec, ndims, dimList, irecord, myIter, mythid )
1319 endif
1320
1321 _END_MASTER( myThid )
1322 C ------------------------------------------------------------------
1323 return
1324 end
1325 C=======================================================================
1326
1327 C=======================================================================
1328 subroutine MDS_WRITE_RS_VEC( dUnit, irec, narr, arr, mythid )
1329 C IN:
1330 C dunit integer - 'Opened' I/O channel
1331 C irec integer - record number to write
1332 C narr integer - dimension off array "arr"
1333 C arr _RS - model tiled vector
1334 C mythid integer - thread id
1335 C
1336 C Created: 03/29/99 eckert@mit.edu + adcroft@mit.edu
1337
1338 implicit none
1339
1340 #include "EEPARAMS.h"
1341
1342 C Arguments
1343 integer dUnit
1344 integer irec
1345 integer narr
1346 integer mythid
1347 _RS arr(narr)
1348 C Local
1349 character*(max_len_mbuf) msgbuf
1350 C ------------------------------------------------------------------
1351 write(msgbuf,'(a,i9.8,2x,i9.8)')
1352 & ' MDS_WRITE_RS_VEC: irec = ',irec,narr
1353 call print_message( msgbuf, standardmessageunit,
1354 & SQUEEZE_RIGHT , mythid)
1355 write(dUnit,rec=irec) arr
1356 C ------------------------------------------------------------------
1357 return
1358 end
1359 C=======================================================================
1360
1361 C=======================================================================
1362 subroutine MDS_WRITE_RL_VEC( dUnit, irec, narr, arr, mythid )
1363 C IN:
1364 C dunit integer - 'Opened' I/O channel
1365 C irec integer - record number to write
1366 C narr integer - dimension off array "arr"
1367 C arr _RL - model tiled vector
1368 C mythid integer - thread id
1369 C
1370 C Created: 03/29/99 eckert@mit.edu + adcroft@mit.edu
1371
1372 implicit none
1373
1374 #include "EEPARAMS.h"
1375
1376 C Arguments
1377 integer dUnit
1378 integer irec
1379 integer narr
1380 integer mythid
1381 _RL arr(narr)
1382 C Local
1383 character*(max_len_mbuf) msgbuf
1384 C ------------------------------------------------------------------
1385 write(msgbuf,'(a,i9.8,2x,i9.8)')
1386 & ' MDS_WRITE_RL_VEC: irec = ',irec,narr
1387 call print_message( msgbuf, standardmessageunit,
1388 & SQUEEZE_RIGHT , mythid)
1389 write(dUnit,rec=irec) arr
1390 C ------------------------------------------------------------------
1391 return
1392 end
1393 C=======================================================================
1394
1395 C=======================================================================
1396 subroutine MDS_READ_RS_VEC( dUnit, irec, narr, arr, mythid )
1397 C IN:
1398 C dunit integer - 'Opened' I/O channel
1399 C irec integer - record number to write
1400 C narr integer - dimension off array "arr"
1401 C mythid integer - thread id
1402 C OUT:
1403 C arr _RS - model tiled vector
1404 C
1405 C Created: 03/29/99 eckert@mit.edu + adcroft@mit.edu
1406
1407 implicit none
1408
1409 #include "EEPARAMS.h"
1410
1411 C Arguments
1412 integer dUnit
1413 integer irec
1414 integer narr
1415 _RS arr(narr)
1416 integer mythid
1417 C Local
1418 character*(max_len_mbuf) msgbuf
1419 C ------------------------------------------------------------------
1420 write(msgbuf,'(a,i9.8,2x,i9.8)')
1421 & ' MDS_READ_RS_VEC: irec = ',irec,narr
1422 call print_message( msgbuf, standardmessageunit,
1423 & SQUEEZE_RIGHT , mythid)
1424 read(dUnit,rec=irec) arr
1425 C ------------------------------------------------------------------
1426 return
1427 end
1428 C=======================================================================
1429
1430 C=======================================================================
1431 subroutine MDS_READ_RL_VEC( dUnit, irec, narr, arr, mythid )
1432 C IN:
1433 C dunit integer - 'Opened' I/O channel
1434 C irec integer - record number to write
1435 C narr integer - dimension off array "arr"
1436 C mythid integer - thread id
1437 C OUT:
1438 C arr _RL - model tiled vector
1439 C
1440 C Created: 03/29/99 eckert@mit.edu + adcroft@mit.edu
1441
1442 implicit none
1443
1444 #include "EEPARAMS.h"
1445
1446 C Arguments
1447 integer dUnit
1448 integer irec
1449 integer narr
1450 _RL arr(narr)
1451 integer mythid
1452 C Local
1453 character*(max_len_mbuf) msgbuf
1454 C ------------------------------------------------------------------
1455 write(msgbuf,'(a,i9.8,2x,i9.8)')
1456 & ' MDS_READ_RL_VEC: irec = ',irec,narr
1457 call print_message( msgbuf, standardmessageunit,
1458 & SQUEEZE_RIGHT , mythid)
1459 read(dUnit,rec=irec) arr
1460 C ------------------------------------------------------------------
1461 return
1462 end
1463 C=======================================================================
1464
1465 #ifdef _BYTESWAPIO
1466 C=======================================================================
1467 subroutine MDS_BYTESWAPR4( n, arr )
1468 C IN:
1469 C n integer - Number of 4-byte words in arr
1470 C IN/OUT:
1471 C arr real*4 - Array declared as real*4(n)
1472 C
1473 C Created: 05/05/99 adcroft@mit.edu (This is an unfortunate hack!!)
1474
1475 implicit none
1476 C Arguments
1477 integer n
1478 character*(*) arr
1479 C Local
1480 integer i
1481 character*(1) cc
1482 C ------------------------------------------------------------------
1483 do i=1,4*n,4
1484 cc=arr(i:i)
1485 arr(i:i)=arr(i+3:i+3)
1486 arr(i+3:i+3)=cc
1487 cc=arr(i+1:i+1)
1488 arr(i+1:i+1)=arr(i+2:i+2)
1489 arr(i+2:i+2)=cc
1490 enddo
1491 C ------------------------------------------------------------------
1492 return
1493 end
1494 C=======================================================================
1495
1496 C=======================================================================
1497 subroutine MDS_BYTESWAPR8( n, arr )
1498 C IN:
1499 C n integer - Number of 8-byte words in arr
1500 C IN/OUT:
1501 C arr real*8 - Array declared as real*4(n)
1502 C
1503 C Created: 05/05/99 adcroft@mit.edu (This is an unfortunate hack!!)
1504
1505 implicit none
1506 C Arguments
1507 integer n
1508 character*(*) arr
1509 C Local
1510 integer i
1511 character*(1) cc
1512 C ------------------------------------------------------------------
1513 do i=1,8*n,8
1514 cc=arr(i:i)
1515 arr(i:i)=arr(i+7:i+7)
1516 arr(i+7:i+7)=cc
1517 cc=arr(i+1:i+1)
1518 arr(i+1:i+1)=arr(i+6:i+6)
1519 arr(i+6:i+6)=cc
1520 cc=arr(i+2:i+2)
1521 arr(i+2:i+2)=arr(i+5:i+5)
1522 arr(i+5:i+5)=cc
1523 cc=arr(i+3:i+3)
1524 arr(i+3:i+3)=arr(i+4:i+4)
1525 arr(i+4:i+4)=cc
1526 enddo
1527 C ------------------------------------------------------------------
1528 return
1529 end
1530 C=======================================================================
1531 #endif
1532
  ViewVC Help
Powered by ViewVC 1.1.22