/[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.8 - (hide annotations) (download)
Wed Jan 12 20:33:13 2005 UTC (20 years, 5 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint57d_post, checkpoint57c_post, checkpoint57c_pre
Changes since 1.7: +3 -3 lines 
o small fix in mdsio_gl
o make diag_ output 2-dim instead of 1-dim for unpack fluxes
  (i.e. make same as pack).
1 heimbach 1.8 C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_gl.F,v 1.7 2005/01/12 19:15:03 heimbach Exp $
2 adcroft 1.1
3 edhill 1.4 #include "MDSIO_OPTIONS.h"
4 heimbach 1.2
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 adcroft 1.1
29     C=======================================================================
30 heimbach 1.2 SUBROUTINE MDSREADFIELD_3D_GL(
31 adcroft 1.1 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 heimbach 1.2 C Created: 03/16/99 adcroft@mit.edu
65 adcroft 1.1
66     implicit none
67     C Global variables / common blocks
68     #include "SIZE.h"
69     #include "EEPARAMS.h"
70 heimbach 1.7 #include "EESUPPORT.h"
71 adcroft 1.1 #include "PARAMS.h"
72    
73     C Routine arguments
74     character*(*) fName
75     integer filePrec
76     character*(2) arrType
77     integer nNz
78 heimbach 1.2 _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
79 adcroft 1.1 integer irecord
80     integer myThid
81     C Functions
82     integer ILNBLNK
83     integer MDS_RECLEN
84     C Local variables
85     character*(80) dataFName
86     integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
87     logical exst
88     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
89     Real*4 r4seg(sNx)
90     Real*8 r8seg(sNx)
91     logical globalFile,fileIsOpen
92     integer length_of_rec
93     character*(max_len_mbuf) msgbuf
94     C ------------------------------------------------------------------
95    
96     C Only do I/O if I am the master thread
97     _BEGIN_MASTER( myThid )
98    
99     C Record number must be >= 1
100     if (irecord .LT. 1) then
101     write(msgbuf,'(a,i9.8)')
102     & ' MDSREADFIELD_GL: argument irecord = ',irecord
103     call print_message( msgbuf, standardmessageunit,
104     & SQUEEZE_RIGHT , mythid)
105     write(msgbuf,'(a)')
106     & ' MDSREADFIELD_GL: Invalid value for irecord'
107     call print_error( msgbuf, mythid )
108     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
109     endif
110    
111     C Assume nothing
112     globalFile = .FALSE.
113     fileIsOpen = .FALSE.
114     IL=ILNBLNK( fName )
115    
116     C Assign a free unit number as the I/O channel for this routine
117     call MDSFINDUNIT( dUnit, mythid )
118    
119     C Check first for global file with simple name (ie. fName)
120     dataFName = fName
121     inquire( file=dataFname, exist=exst )
122     if (exst) then
123     write(msgbuf,'(a,a)')
124     & ' MDSREADFIELD: opening global file: ',dataFName
125     call print_message( msgbuf, standardmessageunit,
126     & SQUEEZE_RIGHT , mythid)
127     endif
128    
129     C If negative check for global file with MDS name (ie. fName.data)
130     if (.NOT. globalFile) then
131     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
132     inquire( file=dataFname, exist=exst )
133     if (exst) then
134     write(msgbuf,'(a,a)')
135     & ' MDSREADFIELD_GL: opening global file: ',dataFName
136     call print_message( msgbuf, standardmessageunit,
137     & SQUEEZE_RIGHT , mythid)
138     globalFile = .TRUE.
139     endif
140     endif
141 heimbach 1.7
142     if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
143    
144     C If we are reading from a global file then we open it here
145     if (globalFile) then
146     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
147     open( dUnit, file=dataFName, status='old',
148     & access='direct', recl=length_of_rec )
149     fileIsOpen=.TRUE.
150     endif
151    
152 adcroft 1.1 C Loop over all processors
153     do jp=1,nPy
154     do ip=1,nPx
155     C Loop over all tiles
156     do bj=1,nSy
157     do bi=1,nSx
158     C If we are reading from a tiled MDS file then we open each one here
159     if (.NOT. globalFile) then
160     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
161     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
162     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
163     & fName(1:IL),'.',iG,'.',jG,'.data'
164     inquire( file=dataFname, exist=exst )
165     C Of course, we only open the file if the tile is "active"
166     C (This is a place-holder for the active/passive mechanism
167     if (exst) then
168 heimbach 1.3 if ( debugLevel .GE. debLevA ) then
169     write(msgbuf,'(a,a)')
170 adcroft 1.1 & ' MDSREADFIELD_GL: opening file: ',dataFName
171 heimbach 1.3 call print_message( msgbuf, standardmessageunit,
172 adcroft 1.1 & SQUEEZE_RIGHT , mythid)
173 heimbach 1.3 endif
174 adcroft 1.1 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
175     open( dUnit, file=dataFName, status='old',
176     & access='direct', recl=length_of_rec )
177     fileIsOpen=.TRUE.
178     else
179     fileIsOpen=.FALSE.
180     write(msgbuf,'(a,a)')
181     & ' MDSREADFIELD_GL: filename: ',dataFName
182     call print_message( msgbuf, standardmessageunit,
183     & SQUEEZE_RIGHT , mythid)
184 heimbach 1.6 call print_error( msgbuf, mythid )
185 adcroft 1.1 write(msgbuf,'(a)')
186     & ' MDSREADFIELD_GL: File does not exist'
187 heimbach 1.6 call print_message( msgbuf, standardmessageunit,
188     & SQUEEZE_RIGHT , mythid)
189 adcroft 1.1 call print_error( msgbuf, mythid )
190     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
191     endif
192     endif
193    
194     if (fileIsOpen) then
195 heimbach 1.2 do k=1,Nr
196 adcroft 1.1 do j=1,sNy
197 heimbach 1.7 if (globalFile) then
198     iG=bi+(ip-1)*nsx
199     jG=bj+(jp-1)*nsy
200     irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
201     & + nSx*nPx*Ny*nNz*(irecord-1)
202     else
203 adcroft 1.1 iG = 0
204     jG = 0
205 heimbach 1.2 irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
206 heimbach 1.7 endif
207 adcroft 1.1 if (filePrec .eq. precFloat32) then
208     read(dUnit,rec=irec) r4seg
209     #ifdef _BYTESWAPIO
210     call MDS_BYTESWAPR4( sNx, r4seg )
211     #endif
212     if (arrType .eq. 'RS') then
213 heimbach 1.2 call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
214 adcroft 1.1 elseif (arrType .eq. 'RL') then
215 heimbach 1.2 call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
216 adcroft 1.1 else
217     write(msgbuf,'(a)')
218     & ' MDSREADFIELD_GL: illegal value for arrType'
219     call print_error( msgbuf, mythid )
220     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
221     endif
222     elseif (filePrec .eq. precFloat64) then
223     read(dUnit,rec=irec) r8seg
224     #ifdef _BYTESWAPIO
225     call MDS_BYTESWAPR8( sNx, r8seg )
226     #endif
227     if (arrType .eq. 'RS') then
228 heimbach 1.2 call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
229 adcroft 1.1 elseif (arrType .eq. 'RL') then
230 heimbach 1.2 call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
231 adcroft 1.1 else
232     write(msgbuf,'(a)')
233     & ' MDSREADFIELD_GL: illegal value for arrType'
234     call print_error( msgbuf, mythid )
235     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
236     endif
237     else
238     write(msgbuf,'(a)')
239     & ' MDSREADFIELD_GL: illegal value for filePrec'
240     call print_error( msgbuf, mythid )
241     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
242     endif
243     do ii=1,sNx
244     arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
245     enddo
246    
247     C End of j loop
248     enddo
249     C End of k loop
250     enddo
251     if (.NOT. globalFile) then
252     close( dUnit )
253     fileIsOpen = .FALSE.
254     endif
255     endif
256     C End of bi,bj loops
257     enddo
258     enddo
259     C End of ip,jp loops
260     enddo
261     enddo
262    
263     C If global file was opened then close it
264     if (fileIsOpen .AND. globalFile) then
265     close( dUnit )
266     fileIsOpen = .FALSE.
267     endif
268    
269 heimbach 1.7 endif
270     c end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
271    
272 adcroft 1.1 _END_MASTER( myThid )
273    
274     C ------------------------------------------------------------------
275     return
276     end
277     C=======================================================================
278    
279     C=======================================================================
280 heimbach 1.2 SUBROUTINE MDSWRITEFIELD_3D_GL(
281 adcroft 1.1 I fName,
282     I filePrec,
283     I arrType,
284     I nNz,
285     I arr_gl,
286     I irecord,
287     I myIter,
288     I myThid )
289     C
290     C Arguments:
291     C
292     C fName string base name for file to written
293     C filePrec integer number of bits per word in file (32 or 64)
294     C arrType char(2) declaration of "arr": either "RS" or "RL"
295     C nNz integer size of third dimension: normally either 1 or Nr
296     C arr RS/RL array to write, arr(:,:,nNz,:,:)
297     C irecord integer record number to read
298     C myIter integer time step number
299     C myThid integer thread identifier
300     C
301     C MDSWRITEFIELD creates either a file of the form "fName.data" and
302     C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
303     C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
304     C "fName.xxx.yyy.meta". A meta-file is always created.
305     C Currently, the meta-files are not read because it is difficult
306     C to parse files in fortran. We should read meta information before
307     C adding records to an existing multi-record file.
308     C The precision of the file is decsribed by filePrec, set either
309     C to floatPrec32 or floatPrec64. The precision or declaration of
310     C the array argument must be consistently described by the char*(2)
311     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
312     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
313     C nNz=Nr implies a 3-D model field. irecord is the record number
314     C to be read and must be >= 1. NOTE: It is currently assumed that
315     C the highest record number in the file was the last record written.
316     C Nor is there a consistency check between the routine arguments and file.
317     C ie. if your write record 2 after record 4 the meta information
318     C will record the number of records to be 2. This, again, is because
319     C we have read the meta information. To be fixed.
320     C
321     C Created: 03/16/99 adcroft@mit.edu
322     C
323     C Changed: 05/31/00 heimbach@mit.edu
324     C open(dUnit, ..., status='old', ... -> status='unknown'
325    
326     implicit none
327     C Global variables / common blocks
328     #include "SIZE.h"
329     #include "EEPARAMS.h"
330 heimbach 1.7 #include "EESUPPORT.h"
331 adcroft 1.1 #include "PARAMS.h"
332    
333     C Routine arguments
334     character*(*) fName
335     integer filePrec
336     character*(2) arrType
337     integer nNz
338     cph(
339     cph Real arr(*)
340 heimbach 1.2 _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
341 adcroft 1.1 cph)
342     integer irecord
343     integer myIter
344     integer myThid
345     C Functions
346     integer ILNBLNK
347     integer MDS_RECLEN
348     C Local variables
349     character*(80) dataFName,metaFName
350 heimbach 1.7 integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
351 adcroft 1.1 Real*4 r4seg(sNx)
352     Real*8 r8seg(sNx)
353     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
354     integer dimList(3,3),ndims
355     integer length_of_rec
356     logical fileIsOpen
357     character*(max_len_mbuf) msgbuf
358 heimbach 1.7 cph-usesingle(
359     integer ii,jj
360 heimbach 1.8 integer x_size,y_size,iG_IO,jG_IO,npe
361 heimbach 1.7 PARAMETER ( x_size = Nx )
362     PARAMETER ( y_size = Ny )
363     Real*4 xy_buffer_r4(x_size,y_size)
364     Real*8 xy_buffer_r8(x_size,y_size)
365     Real*8 global(Nx,Ny)
366     cph-usesingle)
367    
368 adcroft 1.1 C ------------------------------------------------------------------
369    
370     C Only do I/O if I am the master thread
371     _BEGIN_MASTER( myThid )
372    
373     C Record number must be >= 1
374     if (irecord .LT. 1) then
375     write(msgbuf,'(a,i9.8)')
376     & ' MDSWRITEFIELD_GL: argument irecord = ',irecord
377     call print_message( msgbuf, standardmessageunit,
378     & SQUEEZE_RIGHT , mythid)
379     write(msgbuf,'(a)')
380     & ' MDSWRITEFIELD_GL: invalid value for irecord'
381     call print_error( msgbuf, mythid )
382     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
383     endif
384    
385     C Assume nothing
386     fileIsOpen=.FALSE.
387     IL=ILNBLNK( fName )
388    
389     C Assign a free unit number as the I/O channel for this routine
390     call MDSFINDUNIT( dUnit, mythid )
391    
392 heimbach 1.7 cph-usesingle(
393     #ifdef ALLOW_USE_MPI
394     _END_MASTER( myThid )
395     C If option globalFile is desired but does not work or if
396     C globalFile is too slow, then try using single-CPU I/O.
397     if (useSingleCpuIO) then
398    
399     C Master thread of process 0, only, opens a global file
400     _BEGIN_MASTER( myThid )
401     IF( mpiMyId .EQ. 0 ) THEN
402     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
403     length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
404     if (irecord .EQ. 1) then
405     open( dUnit, file=dataFName, status=_NEW_STATUS,
406     & access='direct', recl=length_of_rec )
407     else
408     open( dUnit, file=dataFName, status=_OLD_STATUS,
409     & access='direct', recl=length_of_rec )
410     endif
411     ENDIF
412     _END_MASTER( myThid )
413    
414     C Gather array and write it to file, one vertical level at a time
415     DO k=1,nNz
416     C Loop over all processors
417     do jp=1,nPy
418     do ip=1,nPx
419     DO bj = myByLo(myThid), myByHi(myThid)
420     DO bi = myBxLo(myThid), myBxHi(myThid)
421     DO J=1,sNy
422     JJ=((jp-1)*nSy+(bj-1))*sNy+J
423     DO I=1,sNx
424     II=((ip-1)*nSx+(bi-1))*sNx+I
425     global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
426     ENDDO
427     ENDDO
428     ENDDO
429     ENDDO
430     enddo
431     enddo
432     _BEGIN_MASTER( myThid )
433     IF( mpiMyId .EQ. 0 ) THEN
434     irec=k+nNz*(irecord-1)
435     if (filePrec .eq. precFloat32) then
436     DO J=1,Ny
437     DO I=1,Nx
438     xy_buffer_r4(I,J) = global(I,J)
439     ENDDO
440     ENDDO
441     #ifdef _BYTESWAPIO
442     call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
443     #endif
444     write(dUnit,rec=irec) xy_buffer_r4
445     elseif (filePrec .eq. precFloat64) then
446     DO J=1,Ny
447     DO I=1,Nx
448     xy_buffer_r8(I,J) = global(I,J)
449     ENDDO
450     ENDDO
451     #ifdef _BYTESWAPIO
452     call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
453     #endif
454     write(dUnit,rec=irec) xy_buffer_r8
455     else
456     write(msgbuf,'(a)')
457     & ' MDSWRITEFIELD: illegal value for filePrec'
458     call print_error( msgbuf, mythid )
459     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
460     endif
461     ENDIF
462     _END_MASTER( myThid )
463     ENDDO
464    
465     C Close data-file and create meta-file
466     _BEGIN_MASTER( myThid )
467     IF( mpiMyId .EQ. 0 ) THEN
468     close( dUnit )
469     write(metaFName(1:80),'(2a)') fName(1:IL),'.meta'
470     dimList(1,1)=Nx
471     dimList(2,1)=1
472     dimList(3,1)=Nx
473     dimList(1,2)=Ny
474     dimList(2,2)=1
475     dimList(3,2)=Ny
476     dimList(1,3)=nNz
477     dimList(2,3)=1
478     dimList(3,3)=nNz
479     ndims=3
480     if (nNz .EQ. 1) ndims=2
481     call MDSWRITEMETA( metaFName, dataFName,
482     & filePrec, ndims, dimList, irecord, myIter, mythid )
483     ENDIF
484     _END_MASTER( myThid )
485     C To be safe, make other processes wait for I/O completion
486     _BARRIER
487    
488     elseif ( .NOT. useSingleCpuIO ) then
489     _BEGIN_MASTER( myThid )
490     #endif /* ALLOW_USE_MPI */
491     cph-usesingle)
492 adcroft 1.1
493     C Loop over all processors
494     do jp=1,nPy
495     do ip=1,nPx
496     C Loop over all tiles
497     do bj=1,nSy
498     do bi=1,nSx
499     C If we are writing to a tiled MDS file then we open each one here
500     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
501     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
502     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
503     & fName(1:IL),'.',iG,'.',jG,'.data'
504     if (irecord .EQ. 1) then
505     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
506     open( dUnit, file=dataFName, status=_NEW_STATUS,
507     & access='direct', recl=length_of_rec )
508     fileIsOpen=.TRUE.
509     else
510     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
511     open( dUnit, file=dataFName, status=_OLD_STATUS,
512     & access='direct', recl=length_of_rec )
513     fileIsOpen=.TRUE.
514     endif
515     if (fileIsOpen) then
516 heimbach 1.2 do k=1,Nr
517 adcroft 1.1 do j=1,sNy
518     do ii=1,sNx
519     arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)
520     enddo
521     iG = 0
522     jG = 0
523 heimbach 1.2 irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
524 adcroft 1.1 if (filePrec .eq. precFloat32) then
525     if (arrType .eq. 'RS') then
526 heimbach 1.2 call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
527 adcroft 1.1 elseif (arrType .eq. 'RL') then
528 heimbach 1.2 call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
529 adcroft 1.1 else
530     write(msgbuf,'(a)')
531     & ' MDSWRITEFIELD_GL: illegal value for arrType'
532     call print_error( msgbuf, mythid )
533     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
534     endif
535     #ifdef _BYTESWAPIO
536     call MDS_BYTESWAPR4( sNx, r4seg )
537     #endif
538     write(dUnit,rec=irec) r4seg
539     elseif (filePrec .eq. precFloat64) then
540     if (arrType .eq. 'RS') then
541 heimbach 1.2 call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
542 adcroft 1.1 elseif (arrType .eq. 'RL') then
543 heimbach 1.2 call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
544 adcroft 1.1 else
545     write(msgbuf,'(a)')
546     & ' MDSWRITEFIELD_GL: illegal value for arrType'
547     call print_error( msgbuf, mythid )
548     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
549     endif
550     #ifdef _BYTESWAPIO
551     call MDS_BYTESWAPR8( sNx, r8seg )
552     #endif
553     write(dUnit,rec=irec) r8seg
554     else
555     write(msgbuf,'(a)')
556     & ' MDSWRITEFIELD_GL: illegal value for filePrec'
557     call print_error( msgbuf, mythid )
558     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
559     endif
560     C End of j loop
561     enddo
562     C End of k loop
563     enddo
564     else
565     write(msgbuf,'(a)')
566     & ' MDSWRITEFIELD_GL: I should never get to this point'
567     call print_error( msgbuf, mythid )
568     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
569     endif
570     C If we were writing to a tiled MDS file then we close it here
571     if (fileIsOpen) then
572     close( dUnit )
573     fileIsOpen = .FALSE.
574     endif
575     C Create meta-file for each tile if we are tiling
576     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
577     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
578     write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
579     & fName(1:IL),'.',iG,'.',jG,'.meta'
580     dimList(1,1)=Nx
581     dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
582     dimList(3,1)=((ip-1)*nSx+bi)*sNx
583     dimList(1,2)=Ny
584     dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
585     dimList(3,2)=((jp-1)*nSy+bj)*sNy
586     dimList(1,3)=Nr
587     dimList(2,3)=1
588     dimList(3,3)=Nr
589     ndims=3
590 heimbach 1.2 if (Nr .EQ. 1) ndims=2
591 adcroft 1.1 call MDSWRITEMETA( metaFName, dataFName,
592     & filePrec, ndims, dimList, irecord, myIter, mythid )
593     C End of bi,bj loops
594     enddo
595     enddo
596     C End of ip,jp loops
597     enddo
598     enddo
599    
600 heimbach 1.7 _END_MASTER( myThid )
601 adcroft 1.1
602 heimbach 1.7 cph-usesingle(
603     #ifdef ALLOW_USE_MPI
604     C endif useSingleCpuIO
605     endif
606     #endif /* ALLOW_USE_MPI */
607     cph-usesingle)
608 adcroft 1.1
609 heimbach 1.2 C ------------------------------------------------------------------
610     return
611     end
612     C=======================================================================
613    
614     C=======================================================================
615     SUBROUTINE MDSREADFIELD_2D_GL(
616     I fName,
617     I filePrec,
618     I arrType,
619     I nNz,
620     O arr_gl,
621     I irecord,
622     I myThid )
623     C
624     C Arguments:
625     C
626     C fName string base name for file to read
627     C filePrec integer number of bits per word in file (32 or 64)
628     C arrType char(2) declaration of "arr": either "RS" or "RL"
629     C nNz integer size of third dimension: normally either 1 or Nr
630     C arr RS/RL array to read into, arr(:,:,nNz,:,:)
631     C irecord integer record number to read
632     C myThid integer thread identifier
633     C
634     C MDSREADFIELD first checks to see if the file "fName" exists, then
635     C if the file "fName.data" exists and finally the tiled files of the
636     C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
637     C read because it is difficult to parse files in fortran.
638     C The precision of the file is decsribed by filePrec, set either
639     C to floatPrec32 or floatPrec64. The precision or declaration of
640     C the array argument must be consistently described by the char*(2)
641     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
642     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
643     C nNz=Nr implies a 3-D model field. irecord is the record number
644     C to be read and must be >= 1. The file data is stored in
645     C arr *but* the overlaps are *not* updated. ie. An exchange must
646     C be called. This is because the routine is sometimes called from
647     C within a MASTER_THID region.
648     C
649     C Created: 03/16/99 adcroft@mit.edu
650    
651     implicit none
652     C Global variables / common blocks
653     #include "SIZE.h"
654     #include "EEPARAMS.h"
655 heimbach 1.7 #include "EESUPPORT.h"
656 heimbach 1.2 #include "PARAMS.h"
657    
658     C Routine arguments
659     character*(*) fName
660     integer filePrec
661     character*(2) arrType
662     integer nNz, nLocz
663     parameter (nLocz = 1)
664     _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
665     integer irecord
666     integer myThid
667     C Functions
668     integer ILNBLNK
669     integer MDS_RECLEN
670     C Local variables
671     character*(80) dataFName
672     integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
673     logical exst
674     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
675     Real*4 r4seg(sNx)
676     Real*8 r8seg(sNx)
677     logical globalFile,fileIsOpen
678     integer length_of_rec
679     character*(max_len_mbuf) msgbuf
680     C ------------------------------------------------------------------
681    
682     C Only do I/O if I am the master thread
683     _BEGIN_MASTER( myThid )
684    
685     C Record number must be >= 1
686     if (irecord .LT. 1) then
687     write(msgbuf,'(a,i9.8)')
688     & ' MDSREADFIELD_GL: argument irecord = ',irecord
689     call print_message( msgbuf, standardmessageunit,
690     & SQUEEZE_RIGHT , mythid)
691     write(msgbuf,'(a)')
692     & ' MDSREADFIELD_GL: Invalid value for irecord'
693     call print_error( msgbuf, mythid )
694     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
695     endif
696    
697     C Assume nothing
698     globalFile = .FALSE.
699     fileIsOpen = .FALSE.
700     IL=ILNBLNK( fName )
701    
702     C Assign a free unit number as the I/O channel for this routine
703     call MDSFINDUNIT( dUnit, mythid )
704    
705     C Check first for global file with simple name (ie. fName)
706     dataFName = fName
707     inquire( file=dataFname, exist=exst )
708     if (exst) then
709     write(msgbuf,'(a,a)')
710     & ' MDSREADFIELD: opening global file: ',dataFName
711     call print_message( msgbuf, standardmessageunit,
712     & SQUEEZE_RIGHT , mythid)
713     endif
714    
715     C If negative check for global file with MDS name (ie. fName.data)
716     if (.NOT. globalFile) then
717     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
718     inquire( file=dataFname, exist=exst )
719     if (exst) then
720     write(msgbuf,'(a,a)')
721     & ' MDSREADFIELD_GL: opening global file: ',dataFName
722     call print_message( msgbuf, standardmessageunit,
723     & SQUEEZE_RIGHT , mythid)
724     globalFile = .TRUE.
725     endif
726     endif
727 heimbach 1.7
728     if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
729    
730     C If we are reading from a global file then we open it here
731     if (globalFile) then
732     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
733     open( dUnit, file=dataFName, status='old',
734     & access='direct', recl=length_of_rec )
735     fileIsOpen=.TRUE.
736     endif
737    
738 heimbach 1.2 C Loop over all processors
739     do jp=1,nPy
740     do ip=1,nPx
741     C Loop over all tiles
742     do bj=1,nSy
743     do bi=1,nSx
744     C If we are reading from a tiled MDS file then we open each one here
745     if (.NOT. globalFile) then
746     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
747     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
748     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
749     & fName(1:IL),'.',iG,'.',jG,'.data'
750     inquire( file=dataFname, exist=exst )
751     C Of course, we only open the file if the tile is "active"
752     C (This is a place-holder for the active/passive mechanism
753     if (exst) then
754 heimbach 1.3 if ( debugLevel .GE. debLevA ) then
755     write(msgbuf,'(a,a)')
756 heimbach 1.2 & ' MDSREADFIELD_GL: opening file: ',dataFName
757 heimbach 1.3 call print_message( msgbuf, standardmessageunit,
758 heimbach 1.2 & SQUEEZE_RIGHT , mythid)
759 heimbach 1.3 endif
760 heimbach 1.2 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
761     open( dUnit, file=dataFName, status='old',
762     & access='direct', recl=length_of_rec )
763     fileIsOpen=.TRUE.
764     else
765     fileIsOpen=.FALSE.
766     write(msgbuf,'(a,a)')
767     & ' MDSREADFIELD_GL: filename: ',dataFName
768     call print_message( msgbuf, standardmessageunit,
769     & SQUEEZE_RIGHT , mythid)
770 heimbach 1.6 call print_error( msgbuf, mythid )
771 heimbach 1.2 write(msgbuf,'(a)')
772     & ' MDSREADFIELD_GL: File does not exist'
773 heimbach 1.6 call print_message( msgbuf, standardmessageunit,
774     & SQUEEZE_RIGHT , mythid)
775 heimbach 1.2 call print_error( msgbuf, mythid )
776     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
777     endif
778     endif
779    
780     if (fileIsOpen) then
781     do k=1,nLocz
782     do j=1,sNy
783 heimbach 1.7 if (globalFile) then
784     iG=bi+(ip-1)*nsx
785     jG=bj+(jp-1)*nsy
786     irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
787     & + nSx*nPx*Ny*nLocz*(irecord-1)
788     else
789 heimbach 1.2 iG = 0
790     jG = 0
791     irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
792 heimbach 1.7 endif
793 heimbach 1.2 if (filePrec .eq. precFloat32) then
794     read(dUnit,rec=irec) r4seg
795     #ifdef _BYTESWAPIO
796     call MDS_BYTESWAPR4( sNx, r4seg )
797 adcroft 1.1 #endif
798 heimbach 1.2 if (arrType .eq. 'RS') then
799     call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
800     elseif (arrType .eq. 'RL') then
801     call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
802     else
803     write(msgbuf,'(a)')
804     & ' MDSREADFIELD_GL: illegal value for arrType'
805     call print_error( msgbuf, mythid )
806     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
807     endif
808     elseif (filePrec .eq. precFloat64) then
809     read(dUnit,rec=irec) r8seg
810     #ifdef _BYTESWAPIO
811     call MDS_BYTESWAPR8( sNx, r8seg )
812     #endif
813     if (arrType .eq. 'RS') then
814     call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
815     elseif (arrType .eq. 'RL') then
816     call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
817     else
818     write(msgbuf,'(a)')
819     & ' MDSREADFIELD_GL: illegal value for arrType'
820     call print_error( msgbuf, mythid )
821     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
822     endif
823     else
824     write(msgbuf,'(a)')
825     & ' MDSREADFIELD_GL: illegal value for filePrec'
826     call print_error( msgbuf, mythid )
827     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
828     endif
829     do ii=1,sNx
830     arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
831     enddo
832    
833     C End of j loop
834     enddo
835     C End of k loop
836     enddo
837     if (.NOT. globalFile) then
838     close( dUnit )
839     fileIsOpen = .FALSE.
840     endif
841     endif
842     C End of bi,bj loops
843     enddo
844     enddo
845     C End of ip,jp loops
846     enddo
847     enddo
848    
849     C If global file was opened then close it
850     if (fileIsOpen .AND. globalFile) then
851     close( dUnit )
852     fileIsOpen = .FALSE.
853     endif
854    
855 heimbach 1.7 endif
856     c end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
857    
858 heimbach 1.2 _END_MASTER( myThid )
859    
860     C ------------------------------------------------------------------
861     return
862     end
863     C=======================================================================
864    
865     C=======================================================================
866     SUBROUTINE MDSWRITEFIELD_2D_GL(
867     I fName,
868     I filePrec,
869     I arrType,
870     I nNz,
871     I arr_gl,
872     I irecord,
873     I myIter,
874     I myThid )
875     C
876     C Arguments:
877     C
878     C fName string base name for file to written
879     C filePrec integer number of bits per word in file (32 or 64)
880     C arrType char(2) declaration of "arr": either "RS" or "RL"
881     C nNz integer size of third dimension: normally either 1 or Nr
882     C arr RS/RL array to write, arr(:,:,nNz,:,:)
883     C irecord integer record number to read
884     C myIter integer time step number
885     C myThid integer thread identifier
886     C
887     C MDSWRITEFIELD creates either a file of the form "fName.data" and
888     C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
889     C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
890     C "fName.xxx.yyy.meta". A meta-file is always created.
891     C Currently, the meta-files are not read because it is difficult
892     C to parse files in fortran. We should read meta information before
893     C adding records to an existing multi-record file.
894     C The precision of the file is decsribed by filePrec, set either
895     C to floatPrec32 or floatPrec64. The precision or declaration of
896     C the array argument must be consistently described by the char*(2)
897     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
898     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
899     C nNz=Nr implies a 3-D model field. irecord is the record number
900     C to be read and must be >= 1. NOTE: It is currently assumed that
901     C the highest record number in the file was the last record written.
902     C Nor is there a consistency check between the routine arguments and file.
903     C ie. if your write record 2 after record 4 the meta information
904     C will record the number of records to be 2. This, again, is because
905     C we have read the meta information. To be fixed.
906     C
907     C Created: 03/16/99 adcroft@mit.edu
908     C
909     C Changed: 05/31/00 heimbach@mit.edu
910     C open(dUnit, ..., status='old', ... -> status='unknown'
911    
912     implicit none
913     C Global variables / common blocks
914     #include "SIZE.h"
915     #include "EEPARAMS.h"
916 heimbach 1.7 #include "EESUPPORT.h"
917 heimbach 1.2 #include "PARAMS.h"
918    
919     C Routine arguments
920     character*(*) fName
921     integer filePrec
922     character*(2) arrType
923     integer nNz, nLocz
924     parameter (nLocz = 1)
925     cph(
926     cph Real arr(*)
927     _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
928     cph)
929     integer irecord
930     integer myIter
931     integer myThid
932     C Functions
933     integer ILNBLNK
934     integer MDS_RECLEN
935     C Local variables
936     character*(80) dataFName,metaFName
937 heimbach 1.7 integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
938 heimbach 1.2 Real*4 r4seg(sNx)
939     Real*8 r8seg(sNx)
940     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
941     integer dimList(3,3),ndims
942     integer length_of_rec
943     logical fileIsOpen
944     character*(max_len_mbuf) msgbuf
945 heimbach 1.7 cph-usesingle(
946     integer ii,jj
947 heimbach 1.8 integer x_size,y_size,iG_IO,jG_IO,npe
948 heimbach 1.7 PARAMETER ( x_size = Nx )
949     PARAMETER ( y_size = Ny )
950     Real*4 xy_buffer_r4(x_size,y_size)
951     Real*8 xy_buffer_r8(x_size,y_size)
952     Real*8 global(Nx,Ny)
953     cph-usesingle)
954    
955 heimbach 1.2 C ------------------------------------------------------------------
956    
957     C Only do I/O if I am the master thread
958     _BEGIN_MASTER( myThid )
959    
960     C Record number must be >= 1
961     if (irecord .LT. 1) then
962     write(msgbuf,'(a,i9.8)')
963     & ' MDSWRITEFIELD_GL: argument irecord = ',irecord
964     call print_message( msgbuf, standardmessageunit,
965     & SQUEEZE_RIGHT , mythid)
966     write(msgbuf,'(a)')
967     & ' MDSWRITEFIELD_GL: invalid value for irecord'
968     call print_error( msgbuf, mythid )
969     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
970     endif
971    
972     C Assume nothing
973     fileIsOpen=.FALSE.
974     IL=ILNBLNK( fName )
975    
976     C Assign a free unit number as the I/O channel for this routine
977     call MDSFINDUNIT( dUnit, mythid )
978    
979    
980 heimbach 1.7 cph-usesingle(
981     #ifdef ALLOW_USE_MPI
982     _END_MASTER( myThid )
983     C If option globalFile is desired but does not work or if
984     C globalFile is too slow, then try using single-CPU I/O.
985     if (useSingleCpuIO) then
986    
987     C Master thread of process 0, only, opens a global file
988     _BEGIN_MASTER( myThid )
989     IF( mpiMyId .EQ. 0 ) THEN
990     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
991     length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
992     if (irecord .EQ. 1) then
993     open( dUnit, file=dataFName, status=_NEW_STATUS,
994     & access='direct', recl=length_of_rec )
995     else
996     open( dUnit, file=dataFName, status=_OLD_STATUS,
997     & access='direct', recl=length_of_rec )
998     endif
999     ENDIF
1000     _END_MASTER( myThid )
1001    
1002     C Gather array and write it to file, one vertical level at a time
1003     DO k=1,nLocz
1004     C Loop over all processors
1005     do jp=1,nPy
1006     do ip=1,nPx
1007     DO bj = myByLo(myThid), myByHi(myThid)
1008     DO bi = myBxLo(myThid), myBxHi(myThid)
1009     DO J=1,sNy
1010     JJ=((jp-1)*nSy+(bj-1))*sNy+J
1011     DO I=1,sNx
1012     II=((ip-1)*nSx+(bi-1))*sNx+I
1013     global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
1014     ENDDO
1015     ENDDO
1016     ENDDO
1017     ENDDO
1018     enddo
1019     enddo
1020     _BEGIN_MASTER( myThid )
1021     IF( mpiMyId .EQ. 0 ) THEN
1022     irec=k+nLocz*(irecord-1)
1023     if (filePrec .eq. precFloat32) then
1024     DO J=1,Ny
1025     DO I=1,Nx
1026     xy_buffer_r4(I,J) = global(I,J)
1027     ENDDO
1028     ENDDO
1029     #ifdef _BYTESWAPIO
1030     call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
1031     #endif
1032     write(dUnit,rec=irec) xy_buffer_r4
1033     elseif (filePrec .eq. precFloat64) then
1034     DO J=1,Ny
1035     DO I=1,Nx
1036     xy_buffer_r8(I,J) = global(I,J)
1037     ENDDO
1038     ENDDO
1039     #ifdef _BYTESWAPIO
1040     call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
1041     #endif
1042     write(dUnit,rec=irec) xy_buffer_r8
1043     else
1044     write(msgbuf,'(a)')
1045     & ' MDSWRITEFIELD: illegal value for filePrec'
1046     call print_error( msgbuf, mythid )
1047     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
1048     endif
1049     ENDIF
1050     _END_MASTER( myThid )
1051     ENDDO
1052    
1053     C Close data-file and create meta-file
1054     _BEGIN_MASTER( myThid )
1055     IF( mpiMyId .EQ. 0 ) THEN
1056     close( dUnit )
1057     write(metaFName(1:80),'(2a)') fName(1:IL),'.meta'
1058     dimList(1,1)=Nx
1059     dimList(2,1)=1
1060     dimList(3,1)=Nx
1061     dimList(1,2)=Ny
1062     dimList(2,2)=1
1063     dimList(3,2)=Ny
1064     dimList(1,3)=nLocz
1065     dimList(2,3)=1
1066     dimList(3,3)=nLocz
1067     ndims=3
1068     if (nLocz .EQ. 1) ndims=2
1069     call MDSWRITEMETA( metaFName, dataFName,
1070     & filePrec, ndims, dimList, irecord, myIter, mythid )
1071     ENDIF
1072     _END_MASTER( myThid )
1073     C To be safe, make other processes wait for I/O completion
1074     _BARRIER
1075    
1076     elseif ( .NOT. useSingleCpuIO ) then
1077     _BEGIN_MASTER( myThid )
1078     #endif /* ALLOW_USE_MPI */
1079     cph-usesingle)
1080    
1081 heimbach 1.2 C Loop over all processors
1082     do jp=1,nPy
1083     do ip=1,nPx
1084     C Loop over all tiles
1085     do bj=1,nSy
1086     do bi=1,nSx
1087     C If we are writing to a tiled MDS file then we open each one here
1088     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1089     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1090     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
1091     & fName(1:IL),'.',iG,'.',jG,'.data'
1092     if (irecord .EQ. 1) then
1093     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1094     open( dUnit, file=dataFName, status=_NEW_STATUS,
1095     & access='direct', recl=length_of_rec )
1096     fileIsOpen=.TRUE.
1097     else
1098     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1099     open( dUnit, file=dataFName, status=_OLD_STATUS,
1100     & access='direct', recl=length_of_rec )
1101     fileIsOpen=.TRUE.
1102     endif
1103     if (fileIsOpen) then
1104     do k=1,nLocz
1105     do j=1,sNy
1106     do ii=1,sNx
1107     arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)
1108     enddo
1109     iG = 0
1110     jG = 0
1111     irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
1112     if (filePrec .eq. precFloat32) then
1113     if (arrType .eq. 'RS') then
1114     call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1115     elseif (arrType .eq. 'RL') then
1116     call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1117     else
1118     write(msgbuf,'(a)')
1119     & ' MDSWRITEFIELD_GL: illegal value for arrType'
1120     call print_error( msgbuf, mythid )
1121     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1122     endif
1123     #ifdef _BYTESWAPIO
1124     call MDS_BYTESWAPR4( sNx, r4seg )
1125     #endif
1126     write(dUnit,rec=irec) r4seg
1127     elseif (filePrec .eq. precFloat64) then
1128     if (arrType .eq. 'RS') then
1129     call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1130     elseif (arrType .eq. 'RL') then
1131     call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1132     else
1133     write(msgbuf,'(a)')
1134     & ' MDSWRITEFIELD_GL: illegal value for arrType'
1135     call print_error( msgbuf, mythid )
1136     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1137     endif
1138     #ifdef _BYTESWAPIO
1139     call MDS_BYTESWAPR8( sNx, r8seg )
1140     #endif
1141     write(dUnit,rec=irec) r8seg
1142     else
1143     write(msgbuf,'(a)')
1144     & ' MDSWRITEFIELD_GL: illegal value for filePrec'
1145     call print_error( msgbuf, mythid )
1146     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1147     endif
1148     C End of j loop
1149     enddo
1150     C End of k loop
1151     enddo
1152     else
1153     write(msgbuf,'(a)')
1154     & ' MDSWRITEFIELD_GL: I should never get to this point'
1155     call print_error( msgbuf, mythid )
1156     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1157     endif
1158     C If we were writing to a tiled MDS file then we close it here
1159     if (fileIsOpen) then
1160     close( dUnit )
1161     fileIsOpen = .FALSE.
1162     endif
1163     C Create meta-file for each tile if we are tiling
1164     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1165     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1166     write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
1167     & fName(1:IL),'.',iG,'.',jG,'.meta'
1168     dimList(1,1)=Nx
1169     dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
1170     dimList(3,1)=((ip-1)*nSx+bi)*sNx
1171     dimList(1,2)=Ny
1172     dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
1173     dimList(3,2)=((jp-1)*nSy+bj)*sNy
1174     dimList(1,3)=Nr
1175     dimList(2,3)=1
1176     dimList(3,3)=Nr
1177     ndims=3
1178     if (nLocz .EQ. 1) ndims=2
1179     call MDSWRITEMETA( metaFName, dataFName,
1180     & filePrec, ndims, dimList, irecord, myIter, mythid )
1181     C End of bi,bj loops
1182     enddo
1183     enddo
1184     C End of ip,jp loops
1185     enddo
1186     enddo
1187    
1188 heimbach 1.7 _END_MASTER( myThid )
1189 heimbach 1.2
1190 heimbach 1.7 #ifdef ALLOW_USE_MPI
1191     C endif useSingleCpuIO
1192     endif
1193     #endif /* ALLOW_USE_MPI */
1194 adcroft 1.1
1195     C ------------------------------------------------------------------
1196     return
1197     end
1198     C=======================================================================
  ViewVC Help
Powered by ViewVC 1.1.22