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

Contents of /MITgcm/pkg/mdsio/mdsio_gl.F

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


Revision 1.6 - (show annotations) (download)
Wed Nov 17 03:04:36 2004 UTC (19 years, 6 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint57b_post, checkpoint56b_post, checkpoint57, checkpoint56, checkpoint57a_post, checkpoint56a_post, checkpoint56c_post, checkpoint57a_pre
Changes since 1.5: +7 -1 lines
mdsreadfield should have file name in both stderr and stdout

1 C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_gl.F,v 1.5 2004/10/14 18:43:39 heimbach Exp $
2
3 #include "MDSIO_OPTIONS.h"
4
5 C The five "public" routines supplied here are:
6 C
7 C MDSREADFIELD - read model field from direct access global or tiled MDS file
8 C MDSWRITEFIELD - write model field to direct access global or tiled MDS file
9 C MDSFINDUNIT - returns an available (unused) I/O channel
10 C MDSREADVECTOR - read vector from direct access global or tiled MDS file
11 C MDSWRITEVECTOR - write vector to direct access global or tiled MDS file
12 C
13 C all other routines are "private" to these utilities and ought
14 C not be accessed directly from the main code.
15 C
16 C Created: 03/16/99 adcroft@mit.edu
17 C Modified: 03/23/99 adcroft@mit.edu
18 C To work with multiple records
19 C Modified: 03/29/99 eckert@mit.edu
20 C Added arbitrary vector capability
21 C Modified: 07/27/99 eckert@mit.edu
22 C Customized for state estimation (--> active_file_control.F)
23 C this relates only to *mdsreadvector* and *mdswritevector*
24 C Modified: 07/28/99 eckert@mit.edu
25 C inserted calls to *print_message* and *print_error*
26 C
27 C To be modified to work with MITgcmuv message routines.
28
29 C=======================================================================
30 SUBROUTINE MDSREADFIELD_3D_GL(
31 I fName,
32 I filePrec,
33 I arrType,
34 I nNz,
35 O arr_gl,
36 I irecord,
37 I myThid )
38 C
39 C Arguments:
40 C
41 C fName string base name for file to read
42 C filePrec integer number of bits per word in file (32 or 64)
43 C arrType char(2) declaration of "arr": either "RS" or "RL"
44 C nNz integer size of third dimension: normally either 1 or Nr
45 C arr RS/RL array to read into, arr(:,:,nNz,:,:)
46 C irecord integer record number to read
47 C myThid integer thread identifier
48 C
49 C MDSREADFIELD first checks to see if the file "fName" exists, then
50 C if the file "fName.data" exists and finally the tiled files of the
51 C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
52 C read because it is difficult to parse files in fortran.
53 C The precision of the file is decsribed by filePrec, set either
54 C to floatPrec32 or floatPrec64. The precision or declaration of
55 C the array argument must be consistently described by the char*(2)
56 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
57 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
58 C nNz=Nr implies a 3-D model field. irecord is the record number
59 C to be read and must be >= 1. The file data is stored in
60 C arr *but* the overlaps are *not* updated. ie. An exchange must
61 C be called. This is because the routine is sometimes called from
62 C within a MASTER_THID region.
63 C
64 C Created: 03/16/99 adcroft@mit.edu
65
66 implicit none
67 C Global variables / common blocks
68 #include "SIZE.h"
69 #include "EEPARAMS.h"
70 #include "PARAMS.h"
71
72 C Routine arguments
73 character*(*) fName
74 integer filePrec
75 character*(2) arrType
76 integer nNz
77 _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
78 integer irecord
79 integer myThid
80 C Functions
81 integer ILNBLNK
82 integer MDS_RECLEN
83 C Local variables
84 character*(80) dataFName
85 integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
86 logical exst
87 _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
88 Real*4 r4seg(sNx)
89 Real*8 r8seg(sNx)
90 logical globalFile,fileIsOpen
91 integer length_of_rec
92 character*(max_len_mbuf) msgbuf
93 C ------------------------------------------------------------------
94
95 C Only do I/O if I am the master thread
96 _BEGIN_MASTER( myThid )
97
98 C Record number must be >= 1
99 if (irecord .LT. 1) then
100 write(msgbuf,'(a,i9.8)')
101 & ' MDSREADFIELD_GL: argument irecord = ',irecord
102 call print_message( msgbuf, standardmessageunit,
103 & SQUEEZE_RIGHT , mythid)
104 write(msgbuf,'(a)')
105 & ' MDSREADFIELD_GL: Invalid value for irecord'
106 call print_error( msgbuf, mythid )
107 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
108 endif
109
110 C Assume nothing
111 globalFile = .FALSE.
112 fileIsOpen = .FALSE.
113 IL=ILNBLNK( fName )
114
115 C Assign a free unit number as the I/O channel for this routine
116 call MDSFINDUNIT( dUnit, mythid )
117
118 C Check first for global file with simple name (ie. fName)
119 dataFName = fName
120 inquire( file=dataFname, exist=exst )
121 if (exst) then
122 write(msgbuf,'(a,a)')
123 & ' MDSREADFIELD: opening global file: ',dataFName
124 call print_message( msgbuf, standardmessageunit,
125 & SQUEEZE_RIGHT , mythid)
126 endif
127
128 C If negative check for global file with MDS name (ie. fName.data)
129 if (.NOT. globalFile) then
130 write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
131 inquire( file=dataFname, exist=exst )
132 if (exst) then
133 write(msgbuf,'(a,a)')
134 & ' MDSREADFIELD_GL: opening global file: ',dataFName
135 call print_message( msgbuf, standardmessageunit,
136 & SQUEEZE_RIGHT , mythid)
137 globalFile = .TRUE.
138 endif
139 endif
140 C Loop over all processors
141 do jp=1,nPy
142 do ip=1,nPx
143 C Loop over all tiles
144 do bj=1,nSy
145 do bi=1,nSx
146 C If we are reading from a tiled MDS file then we open each one here
147 if (.NOT. globalFile) then
148 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
149 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
150 write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
151 & fName(1:IL),'.',iG,'.',jG,'.data'
152 inquire( file=dataFname, exist=exst )
153 C Of course, we only open the file if the tile is "active"
154 C (This is a place-holder for the active/passive mechanism
155 if (exst) then
156 if ( debugLevel .GE. debLevA ) then
157 write(msgbuf,'(a,a)')
158 & ' MDSREADFIELD_GL: opening file: ',dataFName
159 call print_message( msgbuf, standardmessageunit,
160 & SQUEEZE_RIGHT , mythid)
161 endif
162 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
163 open( dUnit, file=dataFName, status='old',
164 & access='direct', recl=length_of_rec )
165 fileIsOpen=.TRUE.
166 else
167 fileIsOpen=.FALSE.
168 write(msgbuf,'(a,a)')
169 & ' MDSREADFIELD_GL: filename: ',dataFName
170 call print_message( msgbuf, standardmessageunit,
171 & SQUEEZE_RIGHT , mythid)
172 call print_error( msgbuf, mythid )
173 write(msgbuf,'(a)')
174 & ' MDSREADFIELD_GL: File does not exist'
175 call print_message( msgbuf, standardmessageunit,
176 & SQUEEZE_RIGHT , mythid)
177 call print_error( msgbuf, mythid )
178 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
179 endif
180 endif
181
182 if (fileIsOpen) then
183 do k=1,Nr
184 do j=1,sNy
185 iG = 0
186 jG = 0
187 irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
188 if (filePrec .eq. precFloat32) then
189 read(dUnit,rec=irec) r4seg
190 #ifdef _BYTESWAPIO
191 call MDS_BYTESWAPR4( sNx, r4seg )
192 #endif
193 if (arrType .eq. 'RS') then
194 call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
195 elseif (arrType .eq. 'RL') then
196 call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
197 else
198 write(msgbuf,'(a)')
199 & ' MDSREADFIELD_GL: illegal value for arrType'
200 call print_error( msgbuf, mythid )
201 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
202 endif
203 elseif (filePrec .eq. precFloat64) then
204 read(dUnit,rec=irec) r8seg
205 #ifdef _BYTESWAPIO
206 call MDS_BYTESWAPR8( sNx, r8seg )
207 #endif
208 if (arrType .eq. 'RS') then
209 call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
210 elseif (arrType .eq. 'RL') then
211 call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
212 else
213 write(msgbuf,'(a)')
214 & ' MDSREADFIELD_GL: illegal value for arrType'
215 call print_error( msgbuf, mythid )
216 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
217 endif
218 else
219 write(msgbuf,'(a)')
220 & ' MDSREADFIELD_GL: illegal value for filePrec'
221 call print_error( msgbuf, mythid )
222 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
223 endif
224 do ii=1,sNx
225 arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
226 enddo
227
228 C End of j loop
229 enddo
230 C End of k loop
231 enddo
232 if (.NOT. globalFile) then
233 close( dUnit )
234 fileIsOpen = .FALSE.
235 endif
236 endif
237 C End of bi,bj loops
238 enddo
239 enddo
240 C End of ip,jp loops
241 enddo
242 enddo
243
244 C If global file was opened then close it
245 if (fileIsOpen .AND. globalFile) then
246 close( dUnit )
247 fileIsOpen = .FALSE.
248 endif
249
250 _END_MASTER( myThid )
251
252 C ------------------------------------------------------------------
253 return
254 end
255 C=======================================================================
256
257 C=======================================================================
258 SUBROUTINE MDSWRITEFIELD_3D_GL(
259 I fName,
260 I filePrec,
261 I arrType,
262 I nNz,
263 I arr_gl,
264 I irecord,
265 I myIter,
266 I myThid )
267 C
268 C Arguments:
269 C
270 C fName string base name for file to written
271 C filePrec integer number of bits per word in file (32 or 64)
272 C arrType char(2) declaration of "arr": either "RS" or "RL"
273 C nNz integer size of third dimension: normally either 1 or Nr
274 C arr RS/RL array to write, arr(:,:,nNz,:,:)
275 C irecord integer record number to read
276 C myIter integer time step number
277 C myThid integer thread identifier
278 C
279 C MDSWRITEFIELD creates either a file of the form "fName.data" and
280 C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
281 C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
282 C "fName.xxx.yyy.meta". A meta-file is always created.
283 C Currently, the meta-files are not read because it is difficult
284 C to parse files in fortran. We should read meta information before
285 C adding records to an existing multi-record file.
286 C The precision of the file is decsribed by filePrec, set either
287 C to floatPrec32 or floatPrec64. The precision or declaration of
288 C the array argument must be consistently described by the char*(2)
289 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
290 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
291 C nNz=Nr implies a 3-D model field. irecord is the record number
292 C to be read and must be >= 1. NOTE: It is currently assumed that
293 C the highest record number in the file was the last record written.
294 C Nor is there a consistency check between the routine arguments and file.
295 C ie. if your write record 2 after record 4 the meta information
296 C will record the number of records to be 2. This, again, is because
297 C we have read the meta information. To be fixed.
298 C
299 C Created: 03/16/99 adcroft@mit.edu
300 C
301 C Changed: 05/31/00 heimbach@mit.edu
302 C open(dUnit, ..., status='old', ... -> status='unknown'
303
304 implicit none
305 C Global variables / common blocks
306 #include "SIZE.h"
307 #include "EEPARAMS.h"
308 #include "PARAMS.h"
309
310 C Routine arguments
311 character*(*) fName
312 integer filePrec
313 character*(2) arrType
314 integer nNz
315 cph(
316 cph Real arr(*)
317 _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
318 cph)
319 integer irecord
320 integer myIter
321 integer myThid
322 C Functions
323 integer ILNBLNK
324 integer MDS_RECLEN
325 C Local variables
326 character*(80) dataFName,metaFName
327 integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
328 Real*4 r4seg(sNx)
329 Real*8 r8seg(sNx)
330 _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
331 integer dimList(3,3),ndims
332 integer length_of_rec
333 logical fileIsOpen
334 character*(max_len_mbuf) msgbuf
335 C ------------------------------------------------------------------
336
337 C Only do I/O if I am the master thread
338 _BEGIN_MASTER( myThid )
339
340 C Record number must be >= 1
341 if (irecord .LT. 1) then
342 write(msgbuf,'(a,i9.8)')
343 & ' MDSWRITEFIELD_GL: argument irecord = ',irecord
344 call print_message( msgbuf, standardmessageunit,
345 & SQUEEZE_RIGHT , mythid)
346 write(msgbuf,'(a)')
347 & ' MDSWRITEFIELD_GL: invalid value for irecord'
348 call print_error( msgbuf, mythid )
349 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
350 endif
351
352 C Assume nothing
353 fileIsOpen=.FALSE.
354 IL=ILNBLNK( fName )
355
356 C Assign a free unit number as the I/O channel for this routine
357 call MDSFINDUNIT( dUnit, mythid )
358
359
360 C Loop over all processors
361 do jp=1,nPy
362 do ip=1,nPx
363 C Loop over all tiles
364 do bj=1,nSy
365 do bi=1,nSx
366 C If we are writing to a tiled MDS file then we open each one here
367 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
368 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
369 write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
370 & fName(1:IL),'.',iG,'.',jG,'.data'
371 if (irecord .EQ. 1) then
372 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
373 open( dUnit, file=dataFName, status=_NEW_STATUS,
374 & access='direct', recl=length_of_rec )
375 fileIsOpen=.TRUE.
376 else
377 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
378 open( dUnit, file=dataFName, status=_OLD_STATUS,
379 & access='direct', recl=length_of_rec )
380 fileIsOpen=.TRUE.
381 endif
382 if (fileIsOpen) then
383 do k=1,Nr
384 do j=1,sNy
385 do ii=1,sNx
386 arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)
387 enddo
388 iG = 0
389 jG = 0
390 irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
391 if (filePrec .eq. precFloat32) then
392 if (arrType .eq. 'RS') then
393 call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
394 elseif (arrType .eq. 'RL') then
395 call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
396 else
397 write(msgbuf,'(a)')
398 & ' MDSWRITEFIELD_GL: illegal value for arrType'
399 call print_error( msgbuf, mythid )
400 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
401 endif
402 #ifdef _BYTESWAPIO
403 call MDS_BYTESWAPR4( sNx, r4seg )
404 #endif
405 write(dUnit,rec=irec) r4seg
406 elseif (filePrec .eq. precFloat64) then
407 if (arrType .eq. 'RS') then
408 call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
409 elseif (arrType .eq. 'RL') then
410 call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
411 else
412 write(msgbuf,'(a)')
413 & ' MDSWRITEFIELD_GL: illegal value for arrType'
414 call print_error( msgbuf, mythid )
415 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
416 endif
417 #ifdef _BYTESWAPIO
418 call MDS_BYTESWAPR8( sNx, r8seg )
419 #endif
420 write(dUnit,rec=irec) r8seg
421 else
422 write(msgbuf,'(a)')
423 & ' MDSWRITEFIELD_GL: illegal value for filePrec'
424 call print_error( msgbuf, mythid )
425 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
426 endif
427 C End of j loop
428 enddo
429 C End of k loop
430 enddo
431 else
432 write(msgbuf,'(a)')
433 & ' MDSWRITEFIELD_GL: I should never get to this point'
434 call print_error( msgbuf, mythid )
435 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
436 endif
437 C If we were writing to a tiled MDS file then we close it here
438 if (fileIsOpen) then
439 close( dUnit )
440 fileIsOpen = .FALSE.
441 endif
442 C Create meta-file for each tile if we are tiling
443 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
444 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
445 write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
446 & fName(1:IL),'.',iG,'.',jG,'.meta'
447 dimList(1,1)=Nx
448 dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
449 dimList(3,1)=((ip-1)*nSx+bi)*sNx
450 dimList(1,2)=Ny
451 dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
452 dimList(3,2)=((jp-1)*nSy+bj)*sNy
453 dimList(1,3)=Nr
454 dimList(2,3)=1
455 dimList(3,3)=Nr
456 ndims=3
457 if (Nr .EQ. 1) ndims=2
458 call MDSWRITEMETA( metaFName, dataFName,
459 & filePrec, ndims, dimList, irecord, myIter, mythid )
460 C End of bi,bj loops
461 enddo
462 enddo
463 C End of ip,jp loops
464 enddo
465 enddo
466
467
468 _END_MASTER( myThid )
469
470 C ------------------------------------------------------------------
471 return
472 end
473 C=======================================================================
474
475 C=======================================================================
476 SUBROUTINE MDSREADFIELD_2D_GL(
477 I fName,
478 I filePrec,
479 I arrType,
480 I nNz,
481 O arr_gl,
482 I irecord,
483 I myThid )
484 C
485 C Arguments:
486 C
487 C fName string base name for file to read
488 C filePrec integer number of bits per word in file (32 or 64)
489 C arrType char(2) declaration of "arr": either "RS" or "RL"
490 C nNz integer size of third dimension: normally either 1 or Nr
491 C arr RS/RL array to read into, arr(:,:,nNz,:,:)
492 C irecord integer record number to read
493 C myThid integer thread identifier
494 C
495 C MDSREADFIELD first checks to see if the file "fName" exists, then
496 C if the file "fName.data" exists and finally the tiled files of the
497 C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
498 C read because it is difficult to parse files in fortran.
499 C The precision of the file is decsribed by filePrec, set either
500 C to floatPrec32 or floatPrec64. The precision or declaration of
501 C the array argument must be consistently described by the char*(2)
502 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
503 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
504 C nNz=Nr implies a 3-D model field. irecord is the record number
505 C to be read and must be >= 1. The file data is stored in
506 C arr *but* the overlaps are *not* updated. ie. An exchange must
507 C be called. This is because the routine is sometimes called from
508 C within a MASTER_THID region.
509 C
510 C Created: 03/16/99 adcroft@mit.edu
511
512 implicit none
513 C Global variables / common blocks
514 #include "SIZE.h"
515 #include "EEPARAMS.h"
516 #include "PARAMS.h"
517
518 C Routine arguments
519 character*(*) fName
520 integer filePrec
521 character*(2) arrType
522 integer nNz, nLocz
523 parameter (nLocz = 1)
524 _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
525 integer irecord
526 integer myThid
527 C Functions
528 integer ILNBLNK
529 integer MDS_RECLEN
530 C Local variables
531 character*(80) dataFName
532 integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
533 logical exst
534 _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
535 Real*4 r4seg(sNx)
536 Real*8 r8seg(sNx)
537 logical globalFile,fileIsOpen
538 integer length_of_rec
539 character*(max_len_mbuf) msgbuf
540 C ------------------------------------------------------------------
541
542 C Only do I/O if I am the master thread
543 _BEGIN_MASTER( myThid )
544
545 C Record number must be >= 1
546 if (irecord .LT. 1) then
547 write(msgbuf,'(a,i9.8)')
548 & ' MDSREADFIELD_GL: argument irecord = ',irecord
549 call print_message( msgbuf, standardmessageunit,
550 & SQUEEZE_RIGHT , mythid)
551 write(msgbuf,'(a)')
552 & ' MDSREADFIELD_GL: Invalid value for irecord'
553 call print_error( msgbuf, mythid )
554 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
555 endif
556
557 C Assume nothing
558 globalFile = .FALSE.
559 fileIsOpen = .FALSE.
560 IL=ILNBLNK( fName )
561
562 C Assign a free unit number as the I/O channel for this routine
563 call MDSFINDUNIT( dUnit, mythid )
564
565 C Check first for global file with simple name (ie. fName)
566 dataFName = fName
567 inquire( file=dataFname, exist=exst )
568 if (exst) then
569 write(msgbuf,'(a,a)')
570 & ' MDSREADFIELD: opening global file: ',dataFName
571 call print_message( msgbuf, standardmessageunit,
572 & SQUEEZE_RIGHT , mythid)
573 endif
574
575 C If negative check for global file with MDS name (ie. fName.data)
576 if (.NOT. globalFile) then
577 write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
578 inquire( file=dataFname, exist=exst )
579 if (exst) then
580 write(msgbuf,'(a,a)')
581 & ' MDSREADFIELD_GL: opening global file: ',dataFName
582 call print_message( msgbuf, standardmessageunit,
583 & SQUEEZE_RIGHT , mythid)
584 globalFile = .TRUE.
585 endif
586 endif
587 C Loop over all processors
588 do jp=1,nPy
589 do ip=1,nPx
590 C Loop over all tiles
591 do bj=1,nSy
592 do bi=1,nSx
593 C If we are reading from a tiled MDS file then we open each one here
594 if (.NOT. globalFile) then
595 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
596 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
597 write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
598 & fName(1:IL),'.',iG,'.',jG,'.data'
599 inquire( file=dataFname, exist=exst )
600 C Of course, we only open the file if the tile is "active"
601 C (This is a place-holder for the active/passive mechanism
602 if (exst) then
603 if ( debugLevel .GE. debLevA ) then
604 write(msgbuf,'(a,a)')
605 & ' MDSREADFIELD_GL: opening file: ',dataFName
606 call print_message( msgbuf, standardmessageunit,
607 & SQUEEZE_RIGHT , mythid)
608 endif
609 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
610 open( dUnit, file=dataFName, status='old',
611 & access='direct', recl=length_of_rec )
612 fileIsOpen=.TRUE.
613 else
614 fileIsOpen=.FALSE.
615 write(msgbuf,'(a,a)')
616 & ' MDSREADFIELD_GL: filename: ',dataFName
617 call print_message( msgbuf, standardmessageunit,
618 & SQUEEZE_RIGHT , mythid)
619 call print_error( msgbuf, mythid )
620 write(msgbuf,'(a)')
621 & ' MDSREADFIELD_GL: File does not exist'
622 call print_message( msgbuf, standardmessageunit,
623 & SQUEEZE_RIGHT , mythid)
624 call print_error( msgbuf, mythid )
625 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
626 endif
627 endif
628
629 if (fileIsOpen) then
630 do k=1,nLocz
631 do j=1,sNy
632 iG = 0
633 jG = 0
634 irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
635 if (filePrec .eq. precFloat32) then
636 read(dUnit,rec=irec) r4seg
637 #ifdef _BYTESWAPIO
638 call MDS_BYTESWAPR4( sNx, r4seg )
639 #endif
640 if (arrType .eq. 'RS') then
641 call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
642 elseif (arrType .eq. 'RL') then
643 call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
644 else
645 write(msgbuf,'(a)')
646 & ' MDSREADFIELD_GL: illegal value for arrType'
647 call print_error( msgbuf, mythid )
648 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
649 endif
650 elseif (filePrec .eq. precFloat64) then
651 read(dUnit,rec=irec) r8seg
652 #ifdef _BYTESWAPIO
653 call MDS_BYTESWAPR8( sNx, r8seg )
654 #endif
655 if (arrType .eq. 'RS') then
656 call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
657 elseif (arrType .eq. 'RL') then
658 call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
659 else
660 write(msgbuf,'(a)')
661 & ' MDSREADFIELD_GL: illegal value for arrType'
662 call print_error( msgbuf, mythid )
663 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
664 endif
665 else
666 write(msgbuf,'(a)')
667 & ' MDSREADFIELD_GL: illegal value for filePrec'
668 call print_error( msgbuf, mythid )
669 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
670 endif
671 do ii=1,sNx
672 arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
673 enddo
674
675 C End of j loop
676 enddo
677 C End of k loop
678 enddo
679 if (.NOT. globalFile) then
680 close( dUnit )
681 fileIsOpen = .FALSE.
682 endif
683 endif
684 C End of bi,bj loops
685 enddo
686 enddo
687 C End of ip,jp loops
688 enddo
689 enddo
690
691 C If global file was opened then close it
692 if (fileIsOpen .AND. globalFile) then
693 close( dUnit )
694 fileIsOpen = .FALSE.
695 endif
696
697 _END_MASTER( myThid )
698
699 C ------------------------------------------------------------------
700 return
701 end
702 C=======================================================================
703
704 C=======================================================================
705 SUBROUTINE MDSWRITEFIELD_2D_GL(
706 I fName,
707 I filePrec,
708 I arrType,
709 I nNz,
710 I arr_gl,
711 I irecord,
712 I myIter,
713 I myThid )
714 C
715 C Arguments:
716 C
717 C fName string base name for file to written
718 C filePrec integer number of bits per word in file (32 or 64)
719 C arrType char(2) declaration of "arr": either "RS" or "RL"
720 C nNz integer size of third dimension: normally either 1 or Nr
721 C arr RS/RL array to write, arr(:,:,nNz,:,:)
722 C irecord integer record number to read
723 C myIter integer time step number
724 C myThid integer thread identifier
725 C
726 C MDSWRITEFIELD creates either a file of the form "fName.data" and
727 C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
728 C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
729 C "fName.xxx.yyy.meta". A meta-file is always created.
730 C Currently, the meta-files are not read because it is difficult
731 C to parse files in fortran. We should read meta information before
732 C adding records to an existing multi-record file.
733 C The precision of the file is decsribed by filePrec, set either
734 C to floatPrec32 or floatPrec64. The precision or declaration of
735 C the array argument must be consistently described by the char*(2)
736 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
737 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
738 C nNz=Nr implies a 3-D model field. irecord is the record number
739 C to be read and must be >= 1. NOTE: It is currently assumed that
740 C the highest record number in the file was the last record written.
741 C Nor is there a consistency check between the routine arguments and file.
742 C ie. if your write record 2 after record 4 the meta information
743 C will record the number of records to be 2. This, again, is because
744 C we have read the meta information. To be fixed.
745 C
746 C Created: 03/16/99 adcroft@mit.edu
747 C
748 C Changed: 05/31/00 heimbach@mit.edu
749 C open(dUnit, ..., status='old', ... -> status='unknown'
750
751 implicit none
752 C Global variables / common blocks
753 #include "SIZE.h"
754 #include "EEPARAMS.h"
755 #include "PARAMS.h"
756
757 C Routine arguments
758 character*(*) fName
759 integer filePrec
760 character*(2) arrType
761 integer nNz, nLocz
762 parameter (nLocz = 1)
763 cph(
764 cph Real arr(*)
765 _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
766 cph)
767 integer irecord
768 integer myIter
769 integer myThid
770 C Functions
771 integer ILNBLNK
772 integer MDS_RECLEN
773 C Local variables
774 character*(80) dataFName,metaFName
775 integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
776 Real*4 r4seg(sNx)
777 Real*8 r8seg(sNx)
778 _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
779 integer dimList(3,3),ndims
780 integer length_of_rec
781 logical fileIsOpen
782 character*(max_len_mbuf) msgbuf
783 C ------------------------------------------------------------------
784
785 C Only do I/O if I am the master thread
786 _BEGIN_MASTER( myThid )
787
788 C Record number must be >= 1
789 if (irecord .LT. 1) then
790 write(msgbuf,'(a,i9.8)')
791 & ' MDSWRITEFIELD_GL: argument irecord = ',irecord
792 call print_message( msgbuf, standardmessageunit,
793 & SQUEEZE_RIGHT , mythid)
794 write(msgbuf,'(a)')
795 & ' MDSWRITEFIELD_GL: invalid value for irecord'
796 call print_error( msgbuf, mythid )
797 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
798 endif
799
800 C Assume nothing
801 fileIsOpen=.FALSE.
802 IL=ILNBLNK( fName )
803
804 C Assign a free unit number as the I/O channel for this routine
805 call MDSFINDUNIT( dUnit, mythid )
806
807
808 C Loop over all processors
809 do jp=1,nPy
810 do ip=1,nPx
811 C Loop over all tiles
812 do bj=1,nSy
813 do bi=1,nSx
814 C If we are writing to a tiled MDS file then we open each one here
815 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
816 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
817 write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
818 & fName(1:IL),'.',iG,'.',jG,'.data'
819 if (irecord .EQ. 1) then
820 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
821 open( dUnit, file=dataFName, status=_NEW_STATUS,
822 & access='direct', recl=length_of_rec )
823 fileIsOpen=.TRUE.
824 else
825 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
826 open( dUnit, file=dataFName, status=_OLD_STATUS,
827 & access='direct', recl=length_of_rec )
828 fileIsOpen=.TRUE.
829 endif
830 if (fileIsOpen) then
831 do k=1,nLocz
832 do j=1,sNy
833 do ii=1,sNx
834 arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)
835 enddo
836 iG = 0
837 jG = 0
838 irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
839 if (filePrec .eq. precFloat32) then
840 if (arrType .eq. 'RS') then
841 call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
842 elseif (arrType .eq. 'RL') then
843 call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
844 else
845 write(msgbuf,'(a)')
846 & ' MDSWRITEFIELD_GL: illegal value for arrType'
847 call print_error( msgbuf, mythid )
848 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
849 endif
850 #ifdef _BYTESWAPIO
851 call MDS_BYTESWAPR4( sNx, r4seg )
852 #endif
853 write(dUnit,rec=irec) r4seg
854 elseif (filePrec .eq. precFloat64) then
855 if (arrType .eq. 'RS') then
856 call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
857 elseif (arrType .eq. 'RL') then
858 call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
859 else
860 write(msgbuf,'(a)')
861 & ' MDSWRITEFIELD_GL: illegal value for arrType'
862 call print_error( msgbuf, mythid )
863 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
864 endif
865 #ifdef _BYTESWAPIO
866 call MDS_BYTESWAPR8( sNx, r8seg )
867 #endif
868 write(dUnit,rec=irec) r8seg
869 else
870 write(msgbuf,'(a)')
871 & ' MDSWRITEFIELD_GL: illegal value for filePrec'
872 call print_error( msgbuf, mythid )
873 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
874 endif
875 C End of j loop
876 enddo
877 C End of k loop
878 enddo
879 else
880 write(msgbuf,'(a)')
881 & ' MDSWRITEFIELD_GL: I should never get to this point'
882 call print_error( msgbuf, mythid )
883 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
884 endif
885 C If we were writing to a tiled MDS file then we close it here
886 if (fileIsOpen) then
887 close( dUnit )
888 fileIsOpen = .FALSE.
889 endif
890 C Create meta-file for each tile if we are tiling
891 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
892 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
893 write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
894 & fName(1:IL),'.',iG,'.',jG,'.meta'
895 dimList(1,1)=Nx
896 dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
897 dimList(3,1)=((ip-1)*nSx+bi)*sNx
898 dimList(1,2)=Ny
899 dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
900 dimList(3,2)=((jp-1)*nSy+bj)*sNy
901 dimList(1,3)=Nr
902 dimList(2,3)=1
903 dimList(3,3)=Nr
904 ndims=3
905 if (nLocz .EQ. 1) ndims=2
906 call MDSWRITEMETA( metaFName, dataFName,
907 & filePrec, ndims, dimList, irecord, myIter, mythid )
908 C End of bi,bj loops
909 enddo
910 enddo
911 C End of ip,jp loops
912 enddo
913 enddo
914
915
916 _END_MASTER( myThid )
917
918 C ------------------------------------------------------------------
919 return
920 end
921 C=======================================================================

  ViewVC Help
Powered by ViewVC 1.1.22