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

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

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

Revision 1.15 - (hide annotations) (download)
Mon May 14 22:53:26 2007 UTC (18 years, 1 month ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint60, checkpoint61, checkpoint59q, checkpoint59p, checkpoint59r, checkpoint59e, checkpoint59d, checkpoint59g, checkpoint59f, checkpoint59c, checkpoint59b, checkpoint59m, checkpoint59l, checkpoint59o, checkpoint59n, checkpoint59i, checkpoint59h, checkpoint59k, checkpoint61f, checkpoint59j, checkpoint61e, checkpoint61g, checkpoint61d, checkpoint61b, checkpoint61c, checkpoint61a
Changes since 1.14: +49 -1 lines 
MOdify usage of mdsioLocalDir (M.Mazloff)
1 heimbach 1.15 C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_gl.F,v 1.14 2005/11/06 01:25:13 jmc Exp $
2 jmc 1.14 C $Name: $
3 adcroft 1.1
4 edhill 1.4 #include "MDSIO_OPTIONS.h"
5 heimbach 1.2
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 adcroft 1.1
30     C=======================================================================
31 heimbach 1.2 SUBROUTINE MDSREADFIELD_3D_GL(
32 adcroft 1.1 I fName,
33     I filePrec,
34     I arrType,
35     I nNz,
36     O arr_gl,
37     I irecord,
38     I myThid )
39     C
40     C Arguments:
41     C
42     C fName string base name for file to read
43     C filePrec integer number of bits per word in file (32 or 64)
44     C arrType char(2) declaration of "arr": either "RS" or "RL"
45     C nNz integer size of third dimension: normally either 1 or Nr
46     C arr RS/RL array to read into, arr(:,:,nNz,:,:)
47     C irecord integer record number to read
48     C myThid integer thread identifier
49     C
50     C MDSREADFIELD first checks to see if the file "fName" exists, then
51     C if the file "fName.data" exists and finally the tiled files of the
52     C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
53     C read because it is difficult to parse files in fortran.
54     C The precision of the file is decsribed by filePrec, set either
55     C to floatPrec32 or floatPrec64. The precision or declaration of
56     C the array argument must be consistently described by the char*(2)
57     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
58     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
59     C nNz=Nr implies a 3-D model field. irecord is the record number
60     C to be read and must be >= 1. The file data is stored in
61     C arr *but* the overlaps are *not* updated. ie. An exchange must
62     C be called. This is because the routine is sometimes called from
63     C within a MASTER_THID region.
64     C
65 heimbach 1.2 C Created: 03/16/99 adcroft@mit.edu
66 adcroft 1.1
67     implicit none
68     C Global variables / common blocks
69     #include "SIZE.h"
70     #include "EEPARAMS.h"
71 heimbach 1.7 #include "EESUPPORT.h"
72 adcroft 1.1 #include "PARAMS.h"
73    
74     C Routine arguments
75     character*(*) fName
76     integer filePrec
77     character*(2) arrType
78     integer nNz
79 heimbach 1.2 _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
80 adcroft 1.1 integer irecord
81     integer myThid
82     C Functions
83     integer ILNBLNK
84     integer MDS_RECLEN
85     C Local variables
86 jmc 1.13 character*(MAX_LEN_FNAM) dataFName
87 heimbach 1.10 integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
88 adcroft 1.1 logical exst
89     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
90     Real*4 r4seg(sNx)
91     Real*8 r8seg(sNx)
92     logical globalFile,fileIsOpen
93     integer length_of_rec
94     character*(max_len_mbuf) msgbuf
95 heimbach 1.9 cph-usesingle(
96     integer ii,jj
97 jmc 1.13 c integer iG_IO,jG_IO,npe
98     integer x_size,y_size
99 heimbach 1.9 PARAMETER ( x_size = Nx )
100     PARAMETER ( y_size = Ny )
101     Real*4 xy_buffer_r4(x_size,y_size)
102     Real*8 xy_buffer_r8(x_size,y_size)
103     Real*8 global(Nx,Ny)
104 jmc 1.13 c _RL local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
105 heimbach 1.9 cph-usesingle)
106 heimbach 1.15 CMM(
107     integer pIL
108     CMM)
109 heimbach 1.9
110 adcroft 1.1 C ------------------------------------------------------------------
111    
112     C Only do I/O if I am the master thread
113     _BEGIN_MASTER( myThid )
114    
115     C Record number must be >= 1
116     if (irecord .LT. 1) then
117     write(msgbuf,'(a,i9.8)')
118     & ' MDSREADFIELD_GL: argument irecord = ',irecord
119     call print_message( msgbuf, standardmessageunit,
120     & SQUEEZE_RIGHT , mythid)
121     write(msgbuf,'(a)')
122     & ' MDSREADFIELD_GL: Invalid value for irecord'
123     call print_error( msgbuf, mythid )
124     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
125     endif
126    
127     C Assume nothing
128     globalFile = .FALSE.
129     fileIsOpen = .FALSE.
130     IL=ILNBLNK( fName )
131 heimbach 1.15 CMM(
132     pIL = ILNBLNK( mdsioLocalDir )
133     CMM)
134     CMM(
135     C Assign special directory
136     if ( pIL.NE.0 ) then
137     write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
138     endif
139     CMM)
140 adcroft 1.1
141     C Assign a free unit number as the I/O channel for this routine
142     call MDSFINDUNIT( dUnit, mythid )
143    
144 heimbach 1.9 if ( useSingleCPUIO ) then
145    
146     #ifdef ALLOW_USE_MPI
147     IF( mpiMyId .EQ. 0 ) THEN
148     #else
149     IF ( .TRUE. ) THEN
150     #endif /* ALLOW_USE_MPI */
151    
152 adcroft 1.1 C Check first for global file with simple name (ie. fName)
153 heimbach 1.9 dataFName = fName
154     inquire( file=dataFname, exist=exst )
155     if (exst) globalFile = .TRUE.
156 adcroft 1.1
157     C If negative check for global file with MDS name (ie. fName.data)
158 heimbach 1.9 if (.NOT. globalFile) then
159 jmc 1.13 write(dataFname,'(2a)') fName(1:IL),'.data'
160 heimbach 1.9 inquire( file=dataFname, exist=exst )
161     if (exst) globalFile = .TRUE.
162     endif
163    
164     C If global file is visible to process 0, then open it here.
165     C Otherwise stop program.
166     if ( globalFile) then
167     length_of_rec=MDS_RECLEN( filePrec, x_size*y_size, mythid )
168     open( dUnit, file=dataFName, status='old',
169     & access='direct', recl=length_of_rec )
170     else
171 jmc 1.13 write(msgbuf,'(2a)')
172     & ' MDSREADFIELD: filename: ',dataFName(1:IL)
173 heimbach 1.9 call print_message( msgbuf, standardmessageunit,
174     & SQUEEZE_RIGHT , mythid)
175     call print_error( msgbuf, mythid )
176     write(msgbuf,'(a)')
177     & ' MDSREADFIELD: File does not exist'
178     call print_message( msgbuf, standardmessageunit,
179     & SQUEEZE_RIGHT , mythid)
180     call print_error( msgbuf, mythid )
181     stop 'ABNORMAL END: S/R MDSREADFIELD'
182     endif
183    
184     ENDIF
185    
186     c-- useSingleCpuIO
187     else
188     C Only do I/O if I am the master thread
189    
190     C Check first for global file with simple name (ie. fName)
191     dataFName = fName
192 adcroft 1.1 inquire( file=dataFname, exist=exst )
193     if (exst) then
194     write(msgbuf,'(a,a)')
195 jmc 1.13 & ' MDSREADFIELD: opening global file: ',dataFName(1:IL)
196 adcroft 1.1 call print_message( msgbuf, standardmessageunit,
197     & SQUEEZE_RIGHT , mythid)
198     endif
199 heimbach 1.9
200     C If negative check for global file with MDS name (ie. fName.data)
201     if (.NOT. globalFile) then
202 jmc 1.13 write(dataFname,'(2a)') fName(1:IL),'.data'
203 heimbach 1.9 inquire( file=dataFname, exist=exst )
204     if (exst) then
205     write(msgbuf,'(a,a)')
206 jmc 1.13 & ' MDSREADFIELD_GL: opening global file: ',dataFName(1:IL+5)
207 heimbach 1.9 call print_message( msgbuf, standardmessageunit,
208     & SQUEEZE_RIGHT , mythid)
209     globalFile = .TRUE.
210     endif
211     endif
212    
213     c-- useSingleCpuIO
214 adcroft 1.1 endif
215 heimbach 1.7
216 heimbach 1.9 if ( .not. useSingleCpuIO ) then
217 heimbach 1.12 cph if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
218 heimbach 1.9 if ( .not. ( globalFile ) ) then
219 heimbach 1.7
220     C If we are reading from a global file then we open it here
221     if (globalFile) then
222     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
223     open( dUnit, file=dataFName, status='old',
224     & access='direct', recl=length_of_rec )
225     fileIsOpen=.TRUE.
226     endif
227    
228 adcroft 1.1 C Loop over all processors
229     do jp=1,nPy
230     do ip=1,nPx
231     C Loop over all tiles
232     do bj=1,nSy
233     do bi=1,nSx
234     C If we are reading from a tiled MDS file then we open each one here
235     if (.NOT. globalFile) then
236     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
237     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
238 jmc 1.13 write(dataFname,'(2a,i3.3,a,i3.3,a)')
239 adcroft 1.1 & fName(1:IL),'.',iG,'.',jG,'.data'
240     inquire( file=dataFname, exist=exst )
241     C Of course, we only open the file if the tile is "active"
242     C (This is a place-holder for the active/passive mechanism
243     if (exst) then
244 heimbach 1.3 if ( debugLevel .GE. debLevA ) then
245     write(msgbuf,'(a,a)')
246 jmc 1.13 & ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)
247 heimbach 1.3 call print_message( msgbuf, standardmessageunit,
248 adcroft 1.1 & SQUEEZE_RIGHT , mythid)
249 heimbach 1.3 endif
250 adcroft 1.1 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
251     open( dUnit, file=dataFName, status='old',
252     & access='direct', recl=length_of_rec )
253     fileIsOpen=.TRUE.
254     else
255     fileIsOpen=.FALSE.
256     write(msgbuf,'(a,a)')
257 jmc 1.13 & ' MDSREADFIELD_GL: filename: ',dataFName(1:IL+13)
258 adcroft 1.1 call print_message( msgbuf, standardmessageunit,
259     & SQUEEZE_RIGHT , mythid)
260 heimbach 1.6 call print_error( msgbuf, mythid )
261 adcroft 1.1 write(msgbuf,'(a)')
262     & ' MDSREADFIELD_GL: File does not exist'
263 heimbach 1.6 call print_message( msgbuf, standardmessageunit,
264     & SQUEEZE_RIGHT , mythid)
265 adcroft 1.1 call print_error( msgbuf, mythid )
266     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
267     endif
268     endif
269    
270     if (fileIsOpen) then
271 heimbach 1.2 do k=1,Nr
272 adcroft 1.1 do j=1,sNy
273 heimbach 1.7 if (globalFile) then
274     iG=bi+(ip-1)*nsx
275     jG=bj+(jp-1)*nsy
276     irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
277     & + nSx*nPx*Ny*nNz*(irecord-1)
278     else
279 adcroft 1.1 iG = 0
280     jG = 0
281 heimbach 1.2 irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
282 heimbach 1.7 endif
283 adcroft 1.1 if (filePrec .eq. precFloat32) then
284     read(dUnit,rec=irec) r4seg
285     #ifdef _BYTESWAPIO
286     call MDS_BYTESWAPR4( sNx, r4seg )
287     #endif
288     if (arrType .eq. 'RS') then
289 heimbach 1.2 call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
290 adcroft 1.1 elseif (arrType .eq. 'RL') then
291 heimbach 1.2 call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
292 adcroft 1.1 else
293     write(msgbuf,'(a)')
294     & ' MDSREADFIELD_GL: illegal value for arrType'
295     call print_error( msgbuf, mythid )
296     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
297     endif
298     elseif (filePrec .eq. precFloat64) then
299     read(dUnit,rec=irec) r8seg
300     #ifdef _BYTESWAPIO
301     call MDS_BYTESWAPR8( sNx, r8seg )
302     #endif
303     if (arrType .eq. 'RS') then
304 heimbach 1.2 call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
305 adcroft 1.1 elseif (arrType .eq. 'RL') then
306 heimbach 1.2 call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
307 adcroft 1.1 else
308     write(msgbuf,'(a)')
309     & ' MDSREADFIELD_GL: illegal value for arrType'
310     call print_error( msgbuf, mythid )
311     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
312     endif
313     else
314     write(msgbuf,'(a)')
315     & ' MDSREADFIELD_GL: illegal value for filePrec'
316     call print_error( msgbuf, mythid )
317     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
318     endif
319     do ii=1,sNx
320     arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
321     enddo
322    
323     C End of j loop
324     enddo
325     C End of k loop
326     enddo
327     if (.NOT. globalFile) then
328     close( dUnit )
329     fileIsOpen = .FALSE.
330     endif
331     endif
332     C End of bi,bj loops
333     enddo
334     enddo
335     C End of ip,jp loops
336     enddo
337     enddo
338    
339     C If global file was opened then close it
340     if (fileIsOpen .AND. globalFile) then
341     close( dUnit )
342     fileIsOpen = .FALSE.
343     endif
344    
345 heimbach 1.9 c end of if ( .not. ( globalFile ) ) then
346     endif
347    
348 heimbach 1.12 c else of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
349 heimbach 1.9 else
350    
351     DO k=1,nNz
352    
353     #ifdef ALLOW_USE_MPI
354     IF( mpiMyId .EQ. 0 ) THEN
355     #else
356     IF ( .TRUE. ) THEN
357     #endif /* ALLOW_USE_MPI */
358     irec = k+nNz*(irecord-1)
359     if (filePrec .eq. precFloat32) then
360     read(dUnit,rec=irec) xy_buffer_r4
361     #ifdef _BYTESWAPIO
362     call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
363     #endif
364     DO J=1,Ny
365     DO I=1,Nx
366     global(I,J) = xy_buffer_r4(I,J)
367     ENDDO
368     ENDDO
369     elseif (filePrec .eq. precFloat64) then
370     read(dUnit,rec=irec) xy_buffer_r8
371     #ifdef _BYTESWAPIO
372     call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
373     #endif
374     DO J=1,Ny
375     DO I=1,Nx
376     global(I,J) = xy_buffer_r8(I,J)
377     ENDDO
378     ENDDO
379     else
380     write(msgbuf,'(a)')
381     & ' MDSREADFIELD: illegal value for filePrec'
382     call print_error( msgbuf, mythid )
383     stop 'ABNORMAL END: S/R MDSREADFIELD'
384     endif
385     ENDIF
386     DO jp=1,nPy
387     DO ip=1,nPx
388     DO bj = myByLo(myThid), myByHi(myThid)
389     DO bi = myBxLo(myThid), myBxHi(myThid)
390     DO J=1,sNy
391     JJ=((jp-1)*nSy+(bj-1))*sNy+J
392     DO I=1,sNx
393     II=((ip-1)*nSx+(bi-1))*sNx+I
394     arr_gl(i,bi,ip,j,bj,jp,k) = global(II,JJ)
395     ENDDO
396     ENDDO
397     ENDDO
398     ENDDO
399     ENDDO
400     ENDDO
401    
402     ENDDO
403     c ENDDO k=1,nNz
404    
405     close( dUnit )
406    
407 heimbach 1.7 endif
408     c end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
409    
410 adcroft 1.1 _END_MASTER( myThid )
411    
412     C ------------------------------------------------------------------
413     return
414     end
415     C=======================================================================
416    
417     C=======================================================================
418 heimbach 1.2 SUBROUTINE MDSWRITEFIELD_3D_GL(
419 adcroft 1.1 I fName,
420     I filePrec,
421     I arrType,
422     I nNz,
423     I arr_gl,
424     I irecord,
425     I myIter,
426     I myThid )
427     C
428     C Arguments:
429     C
430     C fName string base name for file to written
431     C filePrec integer number of bits per word in file (32 or 64)
432     C arrType char(2) declaration of "arr": either "RS" or "RL"
433     C nNz integer size of third dimension: normally either 1 or Nr
434     C arr RS/RL array to write, arr(:,:,nNz,:,:)
435     C irecord integer record number to read
436     C myIter integer time step number
437     C myThid integer thread identifier
438     C
439     C MDSWRITEFIELD creates either a file of the form "fName.data" and
440     C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
441     C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
442     C "fName.xxx.yyy.meta". A meta-file is always created.
443     C Currently, the meta-files are not read because it is difficult
444     C to parse files in fortran. We should read meta information before
445     C adding records to an existing multi-record file.
446     C The precision of the file is decsribed by filePrec, set either
447     C to floatPrec32 or floatPrec64. The precision or declaration of
448     C the array argument must be consistently described by the char*(2)
449     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
450     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
451     C nNz=Nr implies a 3-D model field. irecord is the record number
452     C to be read and must be >= 1. NOTE: It is currently assumed that
453     C the highest record number in the file was the last record written.
454     C Nor is there a consistency check between the routine arguments and file.
455     C ie. if your write record 2 after record 4 the meta information
456     C will record the number of records to be 2. This, again, is because
457     C we have read the meta information. To be fixed.
458     C
459     C Created: 03/16/99 adcroft@mit.edu
460     C
461     C Changed: 05/31/00 heimbach@mit.edu
462     C open(dUnit, ..., status='old', ... -> status='unknown'
463    
464     implicit none
465     C Global variables / common blocks
466     #include "SIZE.h"
467     #include "EEPARAMS.h"
468 heimbach 1.7 #include "EESUPPORT.h"
469 adcroft 1.1 #include "PARAMS.h"
470    
471     C Routine arguments
472     character*(*) fName
473     integer filePrec
474     character*(2) arrType
475     integer nNz
476     cph(
477     cph Real arr(*)
478 heimbach 1.2 _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
479 adcroft 1.1 cph)
480     integer irecord
481     integer myIter
482     integer myThid
483     C Functions
484     integer ILNBLNK
485     integer MDS_RECLEN
486     C Local variables
487 jmc 1.13 character*(MAX_LEN_FNAM) dataFName,metaFName
488 heimbach 1.7 integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
489 adcroft 1.1 Real*4 r4seg(sNx)
490     Real*8 r8seg(sNx)
491     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
492     integer dimList(3,3),ndims
493     integer length_of_rec
494     logical fileIsOpen
495     character*(max_len_mbuf) msgbuf
496 heimbach 1.7 cph-usesingle(
497 jmc 1.13 #ifdef ALLOW_USE_MPI
498 heimbach 1.7 integer ii,jj
499 jmc 1.14 c integer iG_IO,jG_IO,npe
500     integer x_size,y_size
501 heimbach 1.7 PARAMETER ( x_size = Nx )
502     PARAMETER ( y_size = Ny )
503     Real*4 xy_buffer_r4(x_size,y_size)
504     Real*8 xy_buffer_r8(x_size,y_size)
505     Real*8 global(Nx,Ny)
506 jmc 1.13 #endif
507 heimbach 1.7 cph-usesingle)
508 heimbach 1.15 CMM(
509     integer pIL
510     CMM)
511 heimbach 1.7
512 adcroft 1.1 C ------------------------------------------------------------------
513    
514     C Only do I/O if I am the master thread
515     _BEGIN_MASTER( myThid )
516    
517     C Record number must be >= 1
518     if (irecord .LT. 1) then
519     write(msgbuf,'(a,i9.8)')
520     & ' MDSWRITEFIELD_GL: argument irecord = ',irecord
521     call print_message( msgbuf, standardmessageunit,
522     & SQUEEZE_RIGHT , mythid)
523     write(msgbuf,'(a)')
524     & ' MDSWRITEFIELD_GL: invalid value for irecord'
525     call print_error( msgbuf, mythid )
526     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
527     endif
528    
529     C Assume nothing
530     fileIsOpen=.FALSE.
531     IL=ILNBLNK( fName )
532 heimbach 1.15 CMM(
533     pIL = ILNBLNK( mdsioLocalDir )
534     CMM)
535     CMM(
536     C Assign special directory
537     if ( pIL.NE.0 ) then
538     write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
539     endif
540     CMM)
541 adcroft 1.1
542     C Assign a free unit number as the I/O channel for this routine
543     call MDSFINDUNIT( dUnit, mythid )
544    
545 heimbach 1.7 cph-usesingle(
546     #ifdef ALLOW_USE_MPI
547     _END_MASTER( myThid )
548     C If option globalFile is desired but does not work or if
549     C globalFile is too slow, then try using single-CPU I/O.
550     if (useSingleCpuIO) then
551    
552     C Master thread of process 0, only, opens a global file
553     _BEGIN_MASTER( myThid )
554     IF( mpiMyId .EQ. 0 ) THEN
555 jmc 1.13 write(dataFname,'(2a)') fName(1:IL),'.data'
556 heimbach 1.7 length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
557     if (irecord .EQ. 1) then
558     open( dUnit, file=dataFName, status=_NEW_STATUS,
559     & access='direct', recl=length_of_rec )
560     else
561     open( dUnit, file=dataFName, status=_OLD_STATUS,
562     & access='direct', recl=length_of_rec )
563     endif
564     ENDIF
565     _END_MASTER( myThid )
566    
567     C Gather array and write it to file, one vertical level at a time
568     DO k=1,nNz
569     C Loop over all processors
570     do jp=1,nPy
571     do ip=1,nPx
572     DO bj = myByLo(myThid), myByHi(myThid)
573     DO bi = myBxLo(myThid), myBxHi(myThid)
574     DO J=1,sNy
575     JJ=((jp-1)*nSy+(bj-1))*sNy+J
576     DO I=1,sNx
577     II=((ip-1)*nSx+(bi-1))*sNx+I
578     global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
579     ENDDO
580     ENDDO
581     ENDDO
582     ENDDO
583     enddo
584     enddo
585     _BEGIN_MASTER( myThid )
586     IF( mpiMyId .EQ. 0 ) THEN
587     irec=k+nNz*(irecord-1)
588     if (filePrec .eq. precFloat32) then
589     DO J=1,Ny
590     DO I=1,Nx
591     xy_buffer_r4(I,J) = global(I,J)
592     ENDDO
593     ENDDO
594     #ifdef _BYTESWAPIO
595     call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
596     #endif
597     write(dUnit,rec=irec) xy_buffer_r4
598     elseif (filePrec .eq. precFloat64) then
599     DO J=1,Ny
600     DO I=1,Nx
601     xy_buffer_r8(I,J) = global(I,J)
602     ENDDO
603     ENDDO
604     #ifdef _BYTESWAPIO
605     call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
606     #endif
607     write(dUnit,rec=irec) xy_buffer_r8
608     else
609     write(msgbuf,'(a)')
610     & ' MDSWRITEFIELD: illegal value for filePrec'
611     call print_error( msgbuf, mythid )
612     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
613     endif
614     ENDIF
615     _END_MASTER( myThid )
616     ENDDO
617    
618     C Close data-file and create meta-file
619     _BEGIN_MASTER( myThid )
620     IF( mpiMyId .EQ. 0 ) THEN
621     close( dUnit )
622 jmc 1.13 write(metaFName,'(2a)') fName(1:IL),'.meta'
623 heimbach 1.7 dimList(1,1)=Nx
624     dimList(2,1)=1
625     dimList(3,1)=Nx
626     dimList(1,2)=Ny
627     dimList(2,2)=1
628     dimList(3,2)=Ny
629     dimList(1,3)=nNz
630     dimList(2,3)=1
631     dimList(3,3)=nNz
632     ndims=3
633     if (nNz .EQ. 1) ndims=2
634     call MDSWRITEMETA( metaFName, dataFName,
635     & filePrec, ndims, dimList, irecord, myIter, mythid )
636     ENDIF
637     _END_MASTER( myThid )
638     C To be safe, make other processes wait for I/O completion
639     _BARRIER
640    
641     elseif ( .NOT. useSingleCpuIO ) then
642     _BEGIN_MASTER( myThid )
643     #endif /* ALLOW_USE_MPI */
644     cph-usesingle)
645 adcroft 1.1
646     C Loop over all processors
647     do jp=1,nPy
648     do ip=1,nPx
649     C Loop over all tiles
650     do bj=1,nSy
651     do bi=1,nSx
652     C If we are writing to a tiled MDS file then we open each one here
653     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
654     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
655 jmc 1.13 write(dataFname,'(2a,i3.3,a,i3.3,a)')
656 adcroft 1.1 & fName(1:IL),'.',iG,'.',jG,'.data'
657     if (irecord .EQ. 1) then
658     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
659     open( dUnit, file=dataFName, status=_NEW_STATUS,
660     & access='direct', recl=length_of_rec )
661     fileIsOpen=.TRUE.
662     else
663     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
664     open( dUnit, file=dataFName, status=_OLD_STATUS,
665     & access='direct', recl=length_of_rec )
666     fileIsOpen=.TRUE.
667     endif
668     if (fileIsOpen) then
669 heimbach 1.2 do k=1,Nr
670 adcroft 1.1 do j=1,sNy
671 jmc 1.13 do i=1,sNx
672     arr(i,j,k,bi,bj)=arr_gl(i,bi,ip,j,bj,jp,k)
673 adcroft 1.1 enddo
674     iG = 0
675     jG = 0
676 heimbach 1.2 irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
677 adcroft 1.1 if (filePrec .eq. precFloat32) then
678     if (arrType .eq. 'RS') then
679 heimbach 1.2 call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
680 adcroft 1.1 elseif (arrType .eq. 'RL') then
681 heimbach 1.2 call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
682 adcroft 1.1 else
683     write(msgbuf,'(a)')
684     & ' MDSWRITEFIELD_GL: illegal value for arrType'
685     call print_error( msgbuf, mythid )
686     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
687     endif
688     #ifdef _BYTESWAPIO
689     call MDS_BYTESWAPR4( sNx, r4seg )
690     #endif
691     write(dUnit,rec=irec) r4seg
692     elseif (filePrec .eq. precFloat64) then
693     if (arrType .eq. 'RS') then
694 heimbach 1.2 call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
695 adcroft 1.1 elseif (arrType .eq. 'RL') then
696 heimbach 1.2 call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
697 adcroft 1.1 else
698     write(msgbuf,'(a)')
699     & ' MDSWRITEFIELD_GL: illegal value for arrType'
700     call print_error( msgbuf, mythid )
701     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
702     endif
703     #ifdef _BYTESWAPIO
704     call MDS_BYTESWAPR8( sNx, r8seg )
705     #endif
706     write(dUnit,rec=irec) r8seg
707     else
708     write(msgbuf,'(a)')
709     & ' MDSWRITEFIELD_GL: illegal value for filePrec'
710     call print_error( msgbuf, mythid )
711     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
712     endif
713     C End of j loop
714     enddo
715     C End of k loop
716     enddo
717     else
718     write(msgbuf,'(a)')
719     & ' MDSWRITEFIELD_GL: I should never get to this point'
720     call print_error( msgbuf, mythid )
721     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
722     endif
723     C If we were writing to a tiled MDS file then we close it here
724     if (fileIsOpen) then
725     close( dUnit )
726     fileIsOpen = .FALSE.
727     endif
728     C Create meta-file for each tile if we are tiling
729     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
730     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
731 jmc 1.13 write(metaFname,'(2a,i3.3,a,i3.3,a)')
732 adcroft 1.1 & fName(1:IL),'.',iG,'.',jG,'.meta'
733     dimList(1,1)=Nx
734     dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
735     dimList(3,1)=((ip-1)*nSx+bi)*sNx
736     dimList(1,2)=Ny
737     dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
738     dimList(3,2)=((jp-1)*nSy+bj)*sNy
739     dimList(1,3)=Nr
740     dimList(2,3)=1
741     dimList(3,3)=Nr
742     ndims=3
743 heimbach 1.2 if (Nr .EQ. 1) ndims=2
744 adcroft 1.1 call MDSWRITEMETA( metaFName, dataFName,
745     & filePrec, ndims, dimList, irecord, myIter, mythid )
746     C End of bi,bj loops
747     enddo
748     enddo
749     C End of ip,jp loops
750     enddo
751     enddo
752    
753 heimbach 1.7 _END_MASTER( myThid )
754 adcroft 1.1
755 heimbach 1.7 cph-usesingle(
756     #ifdef ALLOW_USE_MPI
757     C endif useSingleCpuIO
758     endif
759     #endif /* ALLOW_USE_MPI */
760     cph-usesingle)
761 adcroft 1.1
762 heimbach 1.2 C ------------------------------------------------------------------
763     return
764     end
765     C=======================================================================
766    
767     C=======================================================================
768     SUBROUTINE MDSREADFIELD_2D_GL(
769     I fName,
770     I filePrec,
771     I arrType,
772     I nNz,
773     O arr_gl,
774     I irecord,
775     I myThid )
776     C
777     C Arguments:
778     C
779     C fName string base name for file to read
780     C filePrec integer number of bits per word in file (32 or 64)
781     C arrType char(2) declaration of "arr": either "RS" or "RL"
782     C nNz integer size of third dimension: normally either 1 or Nr
783     C arr RS/RL array to read into, arr(:,:,nNz,:,:)
784     C irecord integer record number to read
785     C myThid integer thread identifier
786     C
787     C MDSREADFIELD first checks to see if the file "fName" exists, then
788     C if the file "fName.data" exists and finally the tiled files of the
789     C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
790     C read because it is difficult to parse files in fortran.
791     C The precision of the file is decsribed by filePrec, set either
792     C to floatPrec32 or floatPrec64. The precision or declaration of
793     C the array argument must be consistently described by the char*(2)
794     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
795     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
796     C nNz=Nr implies a 3-D model field. irecord is the record number
797     C to be read and must be >= 1. The file data is stored in
798     C arr *but* the overlaps are *not* updated. ie. An exchange must
799     C be called. This is because the routine is sometimes called from
800     C within a MASTER_THID region.
801     C
802     C Created: 03/16/99 adcroft@mit.edu
803    
804     implicit none
805     C Global variables / common blocks
806     #include "SIZE.h"
807     #include "EEPARAMS.h"
808 heimbach 1.7 #include "EESUPPORT.h"
809 heimbach 1.2 #include "PARAMS.h"
810    
811     C Routine arguments
812     character*(*) fName
813     integer filePrec
814     character*(2) arrType
815     integer nNz, nLocz
816     parameter (nLocz = 1)
817     _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
818     integer irecord
819     integer myThid
820     C Functions
821     integer ILNBLNK
822     integer MDS_RECLEN
823     C Local variables
824 jmc 1.13 character*(MAX_LEN_FNAM) dataFName
825 heimbach 1.10 integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
826 heimbach 1.2 logical exst
827     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
828     Real*4 r4seg(sNx)
829     Real*8 r8seg(sNx)
830     logical globalFile,fileIsOpen
831     integer length_of_rec
832     character*(max_len_mbuf) msgbuf
833 heimbach 1.9 cph-usesingle(
834     integer ii,jj
835 jmc 1.13 c integer iG_IO,jG_IO,npe
836     integer x_size,y_size
837 heimbach 1.9 PARAMETER ( x_size = Nx )
838     PARAMETER ( y_size = Ny )
839     Real*4 xy_buffer_r4(x_size,y_size)
840     Real*8 xy_buffer_r8(x_size,y_size)
841     Real*8 global(Nx,Ny)
842 jmc 1.13 c _RL local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
843 heimbach 1.9 cph-usesingle)
844 heimbach 1.15 CMM(
845     integer pIL
846     CMM)
847 heimbach 1.9
848 heimbach 1.2 C ------------------------------------------------------------------
849    
850     C Only do I/O if I am the master thread
851     _BEGIN_MASTER( myThid )
852    
853     C Record number must be >= 1
854     if (irecord .LT. 1) then
855     write(msgbuf,'(a,i9.8)')
856     & ' MDSREADFIELD_GL: argument irecord = ',irecord
857     call print_message( msgbuf, standardmessageunit,
858     & SQUEEZE_RIGHT , mythid)
859     write(msgbuf,'(a)')
860     & ' MDSREADFIELD_GL: Invalid value for irecord'
861     call print_error( msgbuf, mythid )
862     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
863     endif
864    
865     C Assume nothing
866     globalFile = .FALSE.
867     fileIsOpen = .FALSE.
868     IL=ILNBLNK( fName )
869 heimbach 1.15 CMM(
870     pIL = ILNBLNK( mdsioLocalDir )
871     CMM)
872     CMM(
873     C Assign special directory
874     if ( pIL.NE.0 ) then
875     write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
876     endif
877     CMM)
878 heimbach 1.2
879     C Assign a free unit number as the I/O channel for this routine
880     call MDSFINDUNIT( dUnit, mythid )
881    
882 heimbach 1.9 if ( useSingleCPUIO ) then
883    
884     C master thread of process 0, only, opens a global file
885     #ifdef ALLOW_USE_MPI
886     IF( mpiMyId .EQ. 0 ) THEN
887     #else
888     IF ( .TRUE. ) THEN
889     #endif /* ALLOW_USE_MPI */
890    
891 heimbach 1.2 C Check first for global file with simple name (ie. fName)
892 heimbach 1.9 dataFName = fName
893     inquire( file=dataFname, exist=exst )
894     if (exst) globalFile = .TRUE.
895 heimbach 1.2
896     C If negative check for global file with MDS name (ie. fName.data)
897 heimbach 1.9 if (.NOT. globalFile) then
898 jmc 1.13 write(dataFname,'(2a)') fName(1:IL),'.data'
899 heimbach 1.9 inquire( file=dataFname, exist=exst )
900     if (exst) globalFile = .TRUE.
901     endif
902    
903     C If global file is visible to process 0, then open it here.
904     C Otherwise stop program.
905     if ( globalFile) then
906     length_of_rec=MDS_RECLEN( filePrec, x_size*y_size, mythid )
907     open( dUnit, file=dataFName, status='old',
908     & access='direct', recl=length_of_rec )
909     else
910 jmc 1.13 write(msgbuf,'(2a)')
911     & ' MDSREADFIELD: filename: ',dataFName(1:IL)
912 heimbach 1.9 call print_message( msgbuf, standardmessageunit,
913     & SQUEEZE_RIGHT , mythid)
914     call print_error( msgbuf, mythid )
915     write(msgbuf,'(a)')
916     & ' MDSREADFIELD: File does not exist'
917     call print_message( msgbuf, standardmessageunit,
918     & SQUEEZE_RIGHT , mythid)
919     call print_error( msgbuf, mythid )
920     stop 'ABNORMAL END: S/R MDSREADFIELD'
921     endif
922    
923     ENDIF
924    
925     c-- useSingleCpuIO
926     else
927    
928     C Check first for global file with simple name (ie. fName)
929     dataFName = fName
930 heimbach 1.2 inquire( file=dataFname, exist=exst )
931     if (exst) then
932     write(msgbuf,'(a,a)')
933 jmc 1.13 & ' MDSREADFIELD: opening global file: ',dataFName(1:IL)
934 heimbach 1.2 call print_message( msgbuf, standardmessageunit,
935     & SQUEEZE_RIGHT , mythid)
936     endif
937 heimbach 1.9
938     C If negative check for global file with MDS name (ie. fName.data)
939     if (.NOT. globalFile) then
940 jmc 1.13 write(dataFname,'(2a)') fName(1:IL),'.data'
941 heimbach 1.9 inquire( file=dataFname, exist=exst )
942     if (exst) then
943     write(msgbuf,'(a,a)')
944 jmc 1.13 & ' MDSREADFIELD_GL: opening global file: ',dataFName(1:IL+5)
945 heimbach 1.9 call print_message( msgbuf, standardmessageunit,
946     & SQUEEZE_RIGHT , mythid)
947     globalFile = .TRUE.
948     endif
949     endif
950    
951     c-- useSingleCpuIO
952 heimbach 1.2 endif
953 heimbach 1.7
954 heimbach 1.9 if ( .not. useSingleCpuIO ) then
955     cph if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
956     if ( .not. ( globalFile ) ) then
957 heimbach 1.7
958     C If we are reading from a global file then we open it here
959     if (globalFile) then
960     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
961     open( dUnit, file=dataFName, status='old',
962     & access='direct', recl=length_of_rec )
963     fileIsOpen=.TRUE.
964     endif
965    
966 heimbach 1.2 C Loop over all processors
967     do jp=1,nPy
968     do ip=1,nPx
969     C Loop over all tiles
970     do bj=1,nSy
971     do bi=1,nSx
972     C If we are reading from a tiled MDS file then we open each one here
973     if (.NOT. globalFile) then
974     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
975     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
976 jmc 1.13 write(dataFname,'(2a,i3.3,a,i3.3,a)')
977 heimbach 1.2 & fName(1:IL),'.',iG,'.',jG,'.data'
978     inquire( file=dataFname, exist=exst )
979     C Of course, we only open the file if the tile is "active"
980     C (This is a place-holder for the active/passive mechanism
981     if (exst) then
982 heimbach 1.3 if ( debugLevel .GE. debLevA ) then
983     write(msgbuf,'(a,a)')
984 jmc 1.13 & ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)
985 heimbach 1.3 call print_message( msgbuf, standardmessageunit,
986 heimbach 1.2 & SQUEEZE_RIGHT , mythid)
987 heimbach 1.3 endif
988 heimbach 1.2 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
989     open( dUnit, file=dataFName, status='old',
990     & access='direct', recl=length_of_rec )
991     fileIsOpen=.TRUE.
992     else
993     fileIsOpen=.FALSE.
994     write(msgbuf,'(a,a)')
995 jmc 1.13 & ' MDSREADFIELD_GL: filename: ',dataFName(1:IL+13)
996 heimbach 1.2 call print_message( msgbuf, standardmessageunit,
997     & SQUEEZE_RIGHT , mythid)
998 heimbach 1.6 call print_error( msgbuf, mythid )
999 heimbach 1.2 write(msgbuf,'(a)')
1000     & ' MDSREADFIELD_GL: File does not exist'
1001 heimbach 1.6 call print_message( msgbuf, standardmessageunit,
1002     & SQUEEZE_RIGHT , mythid)
1003 heimbach 1.2 call print_error( msgbuf, mythid )
1004     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
1005     endif
1006     endif
1007    
1008     if (fileIsOpen) then
1009     do k=1,nLocz
1010     do j=1,sNy
1011 heimbach 1.7 if (globalFile) then
1012     iG=bi+(ip-1)*nsx
1013     jG=bj+(jp-1)*nsy
1014     irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
1015     & + nSx*nPx*Ny*nLocz*(irecord-1)
1016     else
1017 heimbach 1.2 iG = 0
1018     jG = 0
1019     irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
1020 heimbach 1.7 endif
1021 heimbach 1.2 if (filePrec .eq. precFloat32) then
1022     read(dUnit,rec=irec) r4seg
1023     #ifdef _BYTESWAPIO
1024     call MDS_BYTESWAPR4( sNx, r4seg )
1025 adcroft 1.1 #endif
1026 heimbach 1.2 if (arrType .eq. 'RS') then
1027     call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
1028     elseif (arrType .eq. 'RL') then
1029     call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
1030     else
1031     write(msgbuf,'(a)')
1032     & ' MDSREADFIELD_GL: illegal value for arrType'
1033     call print_error( msgbuf, mythid )
1034     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
1035     endif
1036     elseif (filePrec .eq. precFloat64) then
1037     read(dUnit,rec=irec) r8seg
1038     #ifdef _BYTESWAPIO
1039     call MDS_BYTESWAPR8( sNx, r8seg )
1040     #endif
1041     if (arrType .eq. 'RS') then
1042     call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
1043     elseif (arrType .eq. 'RL') then
1044     call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
1045     else
1046     write(msgbuf,'(a)')
1047     & ' MDSREADFIELD_GL: illegal value for arrType'
1048     call print_error( msgbuf, mythid )
1049     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
1050     endif
1051     else
1052     write(msgbuf,'(a)')
1053     & ' MDSREADFIELD_GL: illegal value for filePrec'
1054     call print_error( msgbuf, mythid )
1055     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
1056     endif
1057     do ii=1,sNx
1058     arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
1059     enddo
1060    
1061     C End of j loop
1062     enddo
1063     C End of k loop
1064     enddo
1065     if (.NOT. globalFile) then
1066     close( dUnit )
1067     fileIsOpen = .FALSE.
1068     endif
1069     endif
1070     C End of bi,bj loops
1071     enddo
1072     enddo
1073     C End of ip,jp loops
1074     enddo
1075     enddo
1076    
1077     C If global file was opened then close it
1078     if (fileIsOpen .AND. globalFile) then
1079     close( dUnit )
1080     fileIsOpen = .FALSE.
1081     endif
1082    
1083 heimbach 1.9 c end of if ( .not. ( globalFile ) ) then
1084     endif
1085    
1086     c else of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
1087     else
1088    
1089     DO k=1,nLocz
1090    
1091     #ifdef ALLOW_USE_MPI
1092     IF( mpiMyId .EQ. 0 ) THEN
1093     #else
1094     IF ( .TRUE. ) THEN
1095     #endif /* ALLOW_USE_MPI */
1096     irec = k+nNz*(irecord-1)
1097     if (filePrec .eq. precFloat32) then
1098     read(dUnit,rec=irec) xy_buffer_r4
1099     #ifdef _BYTESWAPIO
1100     call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
1101     #endif
1102     DO J=1,Ny
1103     DO I=1,Nx
1104     global(I,J) = xy_buffer_r4(I,J)
1105     ENDDO
1106     ENDDO
1107     elseif (filePrec .eq. precFloat64) then
1108     read(dUnit,rec=irec) xy_buffer_r8
1109     #ifdef _BYTESWAPIO
1110     call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
1111     #endif
1112     DO J=1,Ny
1113     DO I=1,Nx
1114     global(I,J) = xy_buffer_r8(I,J)
1115     ENDDO
1116     ENDDO
1117     else
1118     write(msgbuf,'(a)')
1119     & ' MDSREADFIELD: illegal value for filePrec'
1120     call print_error( msgbuf, mythid )
1121     stop 'ABNORMAL END: S/R MDSREADFIELD'
1122     endif
1123     ENDIF
1124     DO jp=1,nPy
1125     DO ip=1,nPx
1126     DO bj = myByLo(myThid), myByHi(myThid)
1127     DO bi = myBxLo(myThid), myBxHi(myThid)
1128     DO J=1,sNy
1129     JJ=((jp-1)*nSy+(bj-1))*sNy+J
1130     DO I=1,sNx
1131     II=((ip-1)*nSx+(bi-1))*sNx+I
1132     arr_gl(i,bi,ip,j,bj,jp,k) = global(II,JJ)
1133     ENDDO
1134     ENDDO
1135     ENDDO
1136     ENDDO
1137     ENDDO
1138     ENDDO
1139    
1140     ENDDO
1141     c ENDDO k=1,nNz
1142    
1143     close( dUnit )
1144    
1145 heimbach 1.7 endif
1146     c end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
1147    
1148 heimbach 1.2 _END_MASTER( myThid )
1149    
1150     C ------------------------------------------------------------------
1151     return
1152     end
1153     C=======================================================================
1154    
1155     C=======================================================================
1156     SUBROUTINE MDSWRITEFIELD_2D_GL(
1157     I fName,
1158     I filePrec,
1159     I arrType,
1160     I nNz,
1161     I arr_gl,
1162     I irecord,
1163     I myIter,
1164     I myThid )
1165     C
1166     C Arguments:
1167     C
1168     C fName string base name for file to written
1169     C filePrec integer number of bits per word in file (32 or 64)
1170     C arrType char(2) declaration of "arr": either "RS" or "RL"
1171     C nNz integer size of third dimension: normally either 1 or Nr
1172     C arr RS/RL array to write, arr(:,:,nNz,:,:)
1173     C irecord integer record number to read
1174     C myIter integer time step number
1175     C myThid integer thread identifier
1176     C
1177     C MDSWRITEFIELD creates either a file of the form "fName.data" and
1178     C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
1179     C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
1180     C "fName.xxx.yyy.meta". A meta-file is always created.
1181     C Currently, the meta-files are not read because it is difficult
1182     C to parse files in fortran. We should read meta information before
1183     C adding records to an existing multi-record file.
1184     C The precision of the file is decsribed by filePrec, set either
1185     C to floatPrec32 or floatPrec64. The precision or declaration of
1186     C the array argument must be consistently described by the char*(2)
1187     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
1188     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
1189     C nNz=Nr implies a 3-D model field. irecord is the record number
1190     C to be read and must be >= 1. NOTE: It is currently assumed that
1191     C the highest record number in the file was the last record written.
1192     C Nor is there a consistency check between the routine arguments and file.
1193     C ie. if your write record 2 after record 4 the meta information
1194     C will record the number of records to be 2. This, again, is because
1195     C we have read the meta information. To be fixed.
1196     C
1197     C Created: 03/16/99 adcroft@mit.edu
1198     C
1199     C Changed: 05/31/00 heimbach@mit.edu
1200     C open(dUnit, ..., status='old', ... -> status='unknown'
1201    
1202     implicit none
1203     C Global variables / common blocks
1204     #include "SIZE.h"
1205     #include "EEPARAMS.h"
1206 heimbach 1.7 #include "EESUPPORT.h"
1207 heimbach 1.2 #include "PARAMS.h"
1208    
1209     C Routine arguments
1210     character*(*) fName
1211     integer filePrec
1212     character*(2) arrType
1213     integer nNz, nLocz
1214     parameter (nLocz = 1)
1215     cph(
1216     cph Real arr(*)
1217     _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
1218     cph)
1219     integer irecord
1220     integer myIter
1221     integer myThid
1222     C Functions
1223     integer ILNBLNK
1224     integer MDS_RECLEN
1225     C Local variables
1226 jmc 1.13 character*(MAX_LEN_FNAM) dataFName,metaFName
1227 heimbach 1.7 integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
1228 heimbach 1.2 Real*4 r4seg(sNx)
1229     Real*8 r8seg(sNx)
1230     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
1231     integer dimList(3,3),ndims
1232     integer length_of_rec
1233     logical fileIsOpen
1234     character*(max_len_mbuf) msgbuf
1235 heimbach 1.7 cph-usesingle(
1236 jmc 1.13 #ifdef ALLOW_USE_MPI
1237 heimbach 1.7 integer ii,jj
1238 jmc 1.14 c integer iG_IO,jG_IO,npe
1239     integer x_size,y_size
1240 heimbach 1.7 PARAMETER ( x_size = Nx )
1241     PARAMETER ( y_size = Ny )
1242     Real*4 xy_buffer_r4(x_size,y_size)
1243     Real*8 xy_buffer_r8(x_size,y_size)
1244     Real*8 global(Nx,Ny)
1245 jmc 1.13 #endif
1246 heimbach 1.7 cph-usesingle)
1247 heimbach 1.15 CMM(
1248     integer pIL
1249     CMM)
1250 heimbach 1.7
1251 heimbach 1.2 C ------------------------------------------------------------------
1252    
1253     C Only do I/O if I am the master thread
1254     _BEGIN_MASTER( myThid )
1255    
1256     C Record number must be >= 1
1257     if (irecord .LT. 1) then
1258     write(msgbuf,'(a,i9.8)')
1259     & ' MDSWRITEFIELD_GL: argument irecord = ',irecord
1260     call print_message( msgbuf, standardmessageunit,
1261     & SQUEEZE_RIGHT , mythid)
1262     write(msgbuf,'(a)')
1263     & ' MDSWRITEFIELD_GL: invalid value for irecord'
1264     call print_error( msgbuf, mythid )
1265     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1266     endif
1267    
1268     C Assume nothing
1269     fileIsOpen=.FALSE.
1270     IL=ILNBLNK( fName )
1271 heimbach 1.15 CMM(
1272     pIL = ILNBLNK( mdsioLocalDir )
1273     CMM)
1274     CMM(
1275     C Assign special directory
1276     if ( pIL.NE.0 ) then
1277     write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
1278     endif
1279     CMM)
1280 heimbach 1.2
1281     C Assign a free unit number as the I/O channel for this routine
1282     call MDSFINDUNIT( dUnit, mythid )
1283    
1284    
1285 heimbach 1.7 cph-usesingle(
1286     #ifdef ALLOW_USE_MPI
1287     _END_MASTER( myThid )
1288     C If option globalFile is desired but does not work or if
1289     C globalFile is too slow, then try using single-CPU I/O.
1290     if (useSingleCpuIO) then
1291    
1292     C Master thread of process 0, only, opens a global file
1293     _BEGIN_MASTER( myThid )
1294     IF( mpiMyId .EQ. 0 ) THEN
1295 jmc 1.13 write(dataFname,'(2a)') fName(1:IL),'.data'
1296 heimbach 1.7 length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
1297     if (irecord .EQ. 1) then
1298     open( dUnit, file=dataFName, status=_NEW_STATUS,
1299     & access='direct', recl=length_of_rec )
1300     else
1301     open( dUnit, file=dataFName, status=_OLD_STATUS,
1302     & access='direct', recl=length_of_rec )
1303     endif
1304     ENDIF
1305     _END_MASTER( myThid )
1306    
1307     C Gather array and write it to file, one vertical level at a time
1308     DO k=1,nLocz
1309     C Loop over all processors
1310     do jp=1,nPy
1311     do ip=1,nPx
1312     DO bj = myByLo(myThid), myByHi(myThid)
1313     DO bi = myBxLo(myThid), myBxHi(myThid)
1314     DO J=1,sNy
1315     JJ=((jp-1)*nSy+(bj-1))*sNy+J
1316     DO I=1,sNx
1317     II=((ip-1)*nSx+(bi-1))*sNx+I
1318     global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
1319     ENDDO
1320     ENDDO
1321     ENDDO
1322     ENDDO
1323     enddo
1324     enddo
1325     _BEGIN_MASTER( myThid )
1326     IF( mpiMyId .EQ. 0 ) THEN
1327     irec=k+nLocz*(irecord-1)
1328     if (filePrec .eq. precFloat32) then
1329     DO J=1,Ny
1330     DO I=1,Nx
1331     xy_buffer_r4(I,J) = global(I,J)
1332     ENDDO
1333     ENDDO
1334     #ifdef _BYTESWAPIO
1335     call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
1336     #endif
1337     write(dUnit,rec=irec) xy_buffer_r4
1338     elseif (filePrec .eq. precFloat64) then
1339     DO J=1,Ny
1340     DO I=1,Nx
1341     xy_buffer_r8(I,J) = global(I,J)
1342     ENDDO
1343     ENDDO
1344     #ifdef _BYTESWAPIO
1345     call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
1346     #endif
1347     write(dUnit,rec=irec) xy_buffer_r8
1348     else
1349     write(msgbuf,'(a)')
1350     & ' MDSWRITEFIELD: illegal value for filePrec'
1351     call print_error( msgbuf, mythid )
1352     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
1353     endif
1354     ENDIF
1355     _END_MASTER( myThid )
1356     ENDDO
1357    
1358     C Close data-file and create meta-file
1359     _BEGIN_MASTER( myThid )
1360     IF( mpiMyId .EQ. 0 ) THEN
1361     close( dUnit )
1362 jmc 1.13 write(metaFName,'(2a)') fName(1:IL),'.meta'
1363 heimbach 1.7 dimList(1,1)=Nx
1364     dimList(2,1)=1
1365     dimList(3,1)=Nx
1366     dimList(1,2)=Ny
1367     dimList(2,2)=1
1368     dimList(3,2)=Ny
1369     dimList(1,3)=nLocz
1370     dimList(2,3)=1
1371     dimList(3,3)=nLocz
1372     ndims=3
1373     if (nLocz .EQ. 1) ndims=2
1374     call MDSWRITEMETA( metaFName, dataFName,
1375     & filePrec, ndims, dimList, irecord, myIter, mythid )
1376     ENDIF
1377     _END_MASTER( myThid )
1378     C To be safe, make other processes wait for I/O completion
1379     _BARRIER
1380    
1381     elseif ( .NOT. useSingleCpuIO ) then
1382     _BEGIN_MASTER( myThid )
1383     #endif /* ALLOW_USE_MPI */
1384     cph-usesingle)
1385    
1386 heimbach 1.2 C Loop over all processors
1387     do jp=1,nPy
1388     do ip=1,nPx
1389     C Loop over all tiles
1390     do bj=1,nSy
1391     do bi=1,nSx
1392     C If we are writing to a tiled MDS file then we open each one here
1393     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1394     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1395 jmc 1.13 write(dataFname,'(2a,i3.3,a,i3.3,a)')
1396 heimbach 1.2 & fName(1:IL),'.',iG,'.',jG,'.data'
1397     if (irecord .EQ. 1) then
1398     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1399     open( dUnit, file=dataFName, status=_NEW_STATUS,
1400     & access='direct', recl=length_of_rec )
1401     fileIsOpen=.TRUE.
1402     else
1403     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1404     open( dUnit, file=dataFName, status=_OLD_STATUS,
1405     & access='direct', recl=length_of_rec )
1406     fileIsOpen=.TRUE.
1407     endif
1408     if (fileIsOpen) then
1409     do k=1,nLocz
1410     do j=1,sNy
1411 jmc 1.13 do i=1,sNx
1412     arr(i,j,k,bi,bj)=arr_gl(i,bi,ip,j,bj,jp,k)
1413 heimbach 1.2 enddo
1414     iG = 0
1415     jG = 0
1416     irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
1417     if (filePrec .eq. precFloat32) then
1418     if (arrType .eq. 'RS') then
1419     call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1420     elseif (arrType .eq. 'RL') then
1421     call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1422     else
1423     write(msgbuf,'(a)')
1424     & ' MDSWRITEFIELD_GL: illegal value for arrType'
1425     call print_error( msgbuf, mythid )
1426     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1427     endif
1428     #ifdef _BYTESWAPIO
1429     call MDS_BYTESWAPR4( sNx, r4seg )
1430     #endif
1431     write(dUnit,rec=irec) r4seg
1432     elseif (filePrec .eq. precFloat64) then
1433     if (arrType .eq. 'RS') then
1434     call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1435     elseif (arrType .eq. 'RL') then
1436     call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1437     else
1438     write(msgbuf,'(a)')
1439     & ' MDSWRITEFIELD_GL: illegal value for arrType'
1440     call print_error( msgbuf, mythid )
1441     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1442     endif
1443     #ifdef _BYTESWAPIO
1444     call MDS_BYTESWAPR8( sNx, r8seg )
1445     #endif
1446     write(dUnit,rec=irec) r8seg
1447     else
1448     write(msgbuf,'(a)')
1449     & ' MDSWRITEFIELD_GL: illegal value for filePrec'
1450     call print_error( msgbuf, mythid )
1451     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1452     endif
1453     C End of j loop
1454     enddo
1455     C End of k loop
1456     enddo
1457     else
1458     write(msgbuf,'(a)')
1459     & ' MDSWRITEFIELD_GL: I should never get to this point'
1460     call print_error( msgbuf, mythid )
1461     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1462     endif
1463     C If we were writing to a tiled MDS file then we close it here
1464     if (fileIsOpen) then
1465     close( dUnit )
1466     fileIsOpen = .FALSE.
1467     endif
1468     C Create meta-file for each tile if we are tiling
1469     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1470     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1471 jmc 1.13 write(metaFname,'(2a,i3.3,a,i3.3,a)')
1472 heimbach 1.2 & fName(1:IL),'.',iG,'.',jG,'.meta'
1473     dimList(1,1)=Nx
1474     dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
1475     dimList(3,1)=((ip-1)*nSx+bi)*sNx
1476     dimList(1,2)=Ny
1477     dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
1478     dimList(3,2)=((jp-1)*nSy+bj)*sNy
1479     dimList(1,3)=Nr
1480     dimList(2,3)=1
1481     dimList(3,3)=Nr
1482     ndims=3
1483     if (nLocz .EQ. 1) ndims=2
1484     call MDSWRITEMETA( metaFName, dataFName,
1485     & filePrec, ndims, dimList, irecord, myIter, mythid )
1486     C End of bi,bj loops
1487     enddo
1488     enddo
1489     C End of ip,jp loops
1490     enddo
1491     enddo
1492    
1493 heimbach 1.7 _END_MASTER( myThid )
1494 heimbach 1.2
1495 heimbach 1.7 #ifdef ALLOW_USE_MPI
1496     C endif useSingleCpuIO
1497     endif
1498     #endif /* ALLOW_USE_MPI */
1499 adcroft 1.1
1500     C ------------------------------------------------------------------
1501     return
1502     end
1503     C=======================================================================
  ViewVC Help
Powered by ViewVC 1.1.22