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

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

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


Revision 1.2 - (hide annotations) (download)
Tue Feb 18 05:33:55 2003 UTC (21 years, 3 months ago) by dimitri
Branch: MAIN
CVS Tags: checkpoint48f_post, checkpoint48i_post, checkpoint50e_post, checkpoint50c_post, checkpoint48h_post, checkpoint50c_pre, checkpoint50d_pre, checkpoint50b_pre, checkpoint49, checkpoint48g_post, checkpoint50, checkpoint50d_post, checkpoint50g_post, checkpoint50b_post, checkpoint50f_post, checkpoint50a_post, checkpoint50f_pre, checkpoint50e_pre
Changes since 1.1: +100 -2 lines
Merging from release1_p12:
o Modifications for using pkg/exf with pkg/seaice
  - improved description of the various forcing configurations
  - added basic radiation bulk formulae to pkg/exf
  - units/sign fix for evap computation in exf_getffields.F
  - updated verification/global_with_exf/results/output.txt
o Added pkg/sbo for computing IERS Special Bureau for the Oceans
  (SBO) core products, including oceanic mass, center-of-mass,
  angular, and bottom pressure (see pkg/sbo/README.sbo).
o Lower bound for viscosity/diffusivity in pkg/kpp/kpp_routines.F
  to avoid negative values in shallow regions.
  - updated verification/natl_box/results/output.txt
  - updated verification/lab_sea/results/output.txt
o MPI gather, scatter: eesupp/src/gather_2d.F and scatter_2d.F
o Added useSingleCpuIO option (see PARAMS.h).
o Updated useSingleCpuIO option in mdsio_writefield.F to
  work with multi-field files, e.g., for single-file pickup.
o pkg/seaice:
  - bug fix in growth.F: QNET for no shortwave case
  - added HeffFile for specifying initial sea-ice thickness
  - changed SEAICE_EXTERNAL_FLUXES wind stress implementation
o Added missing /* */ to CPP comments in pkg/seaice, pkg/exf,
  kpp_transport_t.F, forward_step.F, and the_main_loop.F
o pkg/seaice:
  - adjoint-friendly modifications
  - added a SEAICE_WRITE_PICKUP at end of the_model_main.F

1 dimitri 1.2 C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_writefield.F,v 1.1.6.2 2003/02/07 03:59:42 dimitri Exp $
2     C $Name: $
3 adcroft 1.1
4     #include "MDSIO_OPTIONS.h"
5    
6     SUBROUTINE MDSWRITEFIELD(
7     I fName,
8     I filePrec,
9     I globalFile,
10     I arrType,
11     I nNz,
12     I arr,
13     I irecord,
14     I myIter,
15     I myThid )
16     C
17     C Arguments:
18     C
19     C fName string base name for file to written
20     C filePrec integer number of bits per word in file (32 or 64)
21     C globalFile logical selects between writing a global or tiled file
22     C arrType char(2) declaration of "arr": either "RS" or "RL"
23     C nNz integer size of third dimension: normally either 1 or Nr
24     C arr RS/RL array to write, arr(:,:,nNz,:,:)
25     C irecord integer record number to read
26     C myIter integer time step number
27     C myThid integer thread identifier
28     C
29     C MDSWRITEFIELD creates either a file of the form "fName.data" and
30     C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
31     C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
32     C "fName.xxx.yyy.meta". A meta-file is always created.
33     C Currently, the meta-files are not read because it is difficult
34     C to parse files in fortran. We should read meta information before
35     C adding records to an existing multi-record file.
36     C The precision of the file is decsribed by filePrec, set either
37     C to floatPrec32 or floatPrec64. The precision or declaration of
38     C the array argument must be consistently described by the char*(2)
39     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
40     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
41     C nNz=Nr implies a 3-D model field. irecord is the record number
42     C to be read and must be >= 1. NOTE: It is currently assumed that
43     C the highest record number in the file was the last record written.
44     C Nor is there a consistency check between the routine arguments and file.
45     C ie. if your write record 2 after record 4 the meta information
46     C will record the number of records to be 2. This, again, is because
47     C we have read the meta information. To be fixed.
48     C
49     C Created: 03/16/99 adcroft@mit.edu
50     C
51     C Changed: 05/31/00 heimbach@mit.edu
52     C open(dUnit, ..., status='old', ... -> status='unknown'
53 dimitri 1.2 C
54     C Changed: 01/06/02 menemenlis@jpl.nasa.gov
55     C added useSingleCpuIO hack
56 adcroft 1.1
57     implicit none
58     C Global variables / common blocks
59     #include "SIZE.h"
60     #include "EEPARAMS.h"
61 dimitri 1.2 #include "EESUPPORT.h"
62 adcroft 1.1 #include "PARAMS.h"
63    
64     C Routine arguments
65     character*(*) fName
66     integer filePrec
67     logical globalFile
68     character*(2) arrType
69     integer nNz
70     cph(
71     cph Real arr(*)
72     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nNz,nSx,nSy)
73     cph)
74     integer irecord
75     integer myIter
76     integer myThid
77     C Functions
78     integer ILNBLNK
79     integer MDS_RECLEN
80     C Local variables
81     character*(80) dataFName,metaFName
82     integer iG,jG,irec,bi,bj,j,k,dUnit,IL
83     Real*4 r4seg(sNx)
84     Real*8 r8seg(sNx)
85     integer dimList(3,3),ndims
86     integer length_of_rec
87     logical fileIsOpen
88     character*(max_len_mbuf) msgbuf
89 dimitri 1.2 #ifdef ALLOW_USE_MPI
90     integer i
91     Real*8 global(Nx,Ny)
92     Real*4 global_r4(Nx,Ny)
93     _RL local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
94     #endif /* ALLOW_USE_MPI */
95    
96 adcroft 1.1 C ------------------------------------------------------------------
97    
98     C Only do I/O if I am the master thread
99     _BEGIN_MASTER( myThid )
100    
101     C Record number must be >= 1
102     if (irecord .LT. 1) then
103     write(msgbuf,'(a,i9.8)')
104     & ' MDSWRITEFIELD: argument irecord = ',irecord
105     call print_message( msgbuf, standardmessageunit,
106     & SQUEEZE_RIGHT , mythid)
107     write(msgbuf,'(a)')
108     & ' MDSWRITEFIELD: invalid value for irecord'
109     call print_error( msgbuf, mythid )
110     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
111     endif
112    
113     C Assume nothing
114     fileIsOpen=.FALSE.
115     IL=ILNBLNK( fName )
116    
117     C Assign a free unit number as the I/O channel for this routine
118     call MDSFINDUNIT( dUnit, mythid )
119    
120 dimitri 1.2 #ifdef ALLOW_USE_MPI
121     _END_MASTER( myThid )
122     C If option globalFile is desired but does not work or if
123     C globalFile is too slow, then try using single-CPU I/O.
124     if (useSingleCpuIO) then
125    
126     C Master thread of process 0, only, opens a global file
127     _BEGIN_MASTER( myThid )
128     IF( mpiMyId .EQ. 0 ) THEN
129     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
130     length_of_rec=MDS_RECLEN( filePrec, Nx*Ny, mythid )
131     if (irecord .EQ. 1) then
132     open( dUnit, file=dataFName, status=_NEW_STATUS,
133     & access='direct', recl=length_of_rec )
134     else
135     open( dUnit, file=dataFName, status=_OLD_STATUS,
136     & access='direct', recl=length_of_rec )
137     endif
138     ENDIF
139     _END_MASTER( myThid )
140    
141     C Gather array and write it to file, one vertical level at a time
142     DO k=1,nNz
143     DO bj = myByLo(myThid), myByHi(myThid)
144     DO bi = myBxLo(myThid), myBxHi(myThid)
145     DO J=1-Oly,sNy+Oly
146     DO I=1-Olx,sNx+Olx
147     local(I,J,bi,bj) = arr(I,J,k,bi,bj)
148     ENDDO
149     ENDDO
150     ENDDO
151     ENDDO
152     CALL GATHER_2D( global, local, myThid )
153     _BEGIN_MASTER( myThid )
154     IF( mpiMyId .EQ. 0 ) THEN
155     irec=k+nNz*(irecord-1)
156     if (filePrec .eq. precFloat32) then
157     DO J=1,Ny
158     DO I=1,Nx
159     global_r4(I,J) = global(I,J)
160     ENDDO
161     ENDDO
162     write(dUnit,rec=irec) global_r4
163     elseif (filePrec .eq. precFloat64) then
164     write(dUnit,rec=irec) global
165     else
166     write(msgbuf,'(a)')
167     & ' MDSWRITEFIELD: illegal value for filePrec'
168     call print_error( msgbuf, mythid )
169     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
170     endif
171     ENDIF
172     _END_MASTER( myThid )
173     ENDDO
174    
175     C Close data-file and create meta-file
176     _BEGIN_MASTER( myThid )
177     IF( mpiMyId .EQ. 0 ) THEN
178     close( dUnit )
179     write(metaFName(1:80),'(2a)') fName(1:IL),'.meta'
180     dimList(1,1)=Nx
181     dimList(2,1)=1
182     dimList(3,1)=Nx
183     dimList(1,2)=Ny
184     dimList(2,2)=1
185     dimList(3,2)=Ny
186     dimList(1,3)=Nr
187     dimList(2,3)=1
188     dimList(3,3)=Nr
189     ndims=3
190     if (nNz .EQ. 1) ndims=2
191     call MDSWRITEMETA( metaFName, dataFName,
192     & filePrec, ndims, dimList, irecord, myIter, mythid )
193     ENDIF
194     _END_MASTER( myThid )
195     C To be safe, make other processes wait for I/O completion
196     _BARRIER
197    
198     elseif ( .NOT. useSingleCpuIO ) then
199     _BEGIN_MASTER( myThid )
200     #endif /* ALLOW_USE_MPI */
201    
202 adcroft 1.1 C If we are writing to a global file then we open it here
203     if (globalFile) then
204     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
205     if (irecord .EQ. 1) then
206     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
207     open( dUnit, file=dataFName, status=_NEW_STATUS,
208     & access='direct', recl=length_of_rec )
209     fileIsOpen=.TRUE.
210     else
211     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
212     open( dUnit, file=dataFName, status=_OLD_STATUS,
213     & access='direct', recl=length_of_rec )
214     fileIsOpen=.TRUE.
215     endif
216     endif
217    
218     C Loop over all tiles
219     do bj=1,nSy
220     do bi=1,nSx
221     C If we are writing to a tiled MDS file then we open each one here
222     if (.NOT. globalFile) then
223     iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
224     jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
225     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
226     & fName(1:IL),'.',iG,'.',jG,'.data'
227     if (irecord .EQ. 1) then
228     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
229     open( dUnit, file=dataFName, status=_NEW_STATUS,
230     & access='direct', recl=length_of_rec )
231     fileIsOpen=.TRUE.
232     else
233     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
234     open( dUnit, file=dataFName, status=_OLD_STATUS,
235     & access='direct', recl=length_of_rec )
236     fileIsOpen=.TRUE.
237     endif
238     endif
239     if (fileIsOpen) then
240     do k=1,nNz
241     do j=1,sNy
242     if (globalFile) then
243     iG = myXGlobalLo-1+(bi-1)*sNx
244     jG = myYGlobalLo-1+(bj-1)*sNy
245     irec=1+INT(iG/sNx)+nSx*nPx*(jG+j-1)+nSx*nPx*Ny*(k-1)
246     & +nSx*nPx*Ny*nNz*(irecord-1)
247     else
248     iG = 0
249     jG = 0
250     irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)
251     endif
252     if (filePrec .eq. precFloat32) then
253     if (arrType .eq. 'RS') then
254     call MDS_SEG4toRS( j,bi,bj,k,nNz, r4seg, .FALSE., arr )
255     elseif (arrType .eq. 'RL') then
256     call MDS_SEG4toRL( j,bi,bj,k,nNz, r4seg, .FALSE., arr )
257     else
258     write(msgbuf,'(a)')
259     & ' MDSWRITEFIELD: illegal value for arrType'
260     call print_error( msgbuf, mythid )
261     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
262     endif
263     #ifdef _BYTESWAPIO
264     call MDS_BYTESWAPR4( sNx, r4seg )
265     #endif
266     write(dUnit,rec=irec) r4seg
267     elseif (filePrec .eq. precFloat64) then
268     if (arrType .eq. 'RS') then
269     call MDS_SEG8toRS( j,bi,bj,k,nNz, r8seg, .FALSE., arr )
270     elseif (arrType .eq. 'RL') then
271     call MDS_SEG8toRL( j,bi,bj,k,nNz, r8seg, .FALSE., arr )
272     else
273     write(msgbuf,'(a)')
274     & ' MDSWRITEFIELD: illegal value for arrType'
275     call print_error( msgbuf, mythid )
276     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
277     endif
278     #ifdef _BYTESWAPIO
279     call MDS_BYTESWAPR8( sNx, r8seg )
280     #endif
281     write(dUnit,rec=irec) r8seg
282     else
283     write(msgbuf,'(a)')
284     & ' MDSWRITEFIELD: illegal value for filePrec'
285     call print_error( msgbuf, mythid )
286     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
287     endif
288     C End of j loop
289     enddo
290     C End of k loop
291     enddo
292     else
293     write(msgbuf,'(a)')
294     & ' MDSWRITEFIELD: I should never get to this point'
295     call print_error( msgbuf, mythid )
296     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
297     endif
298     C If we were writing to a tiled MDS file then we close it here
299     if (fileIsOpen .AND. (.NOT. globalFile)) then
300     close( dUnit )
301     fileIsOpen = .FALSE.
302     endif
303     C Create meta-file for each tile if we are tiling
304     if (.NOT. globalFile) then
305     iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
306     jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
307     write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
308     & fName(1:IL),'.',iG,'.',jG,'.meta'
309     dimList(1,1)=Nx
310     dimList(2,1)=myXGlobalLo+(bi-1)*sNx
311     dimList(3,1)=myXGlobalLo+bi*sNx-1
312     dimList(1,2)=Ny
313     dimList(2,2)=myYGlobalLo+(bj-1)*sNy
314     dimList(3,2)=myYGlobalLo+bj*sNy-1
315     dimList(1,3)=Nr
316     dimList(2,3)=1
317     dimList(3,3)=Nr
318     ndims=3
319     if (nNz .EQ. 1) ndims=2
320     call MDSWRITEMETA( metaFName, dataFName,
321     & filePrec, ndims, dimList, irecord, myIter, mythid )
322     endif
323     C End of bi,bj loops
324     enddo
325     enddo
326    
327     C If global file was opened then close it
328     if (fileIsOpen .AND. globalFile) then
329     close( dUnit )
330     fileIsOpen = .FALSE.
331     endif
332    
333     C Create meta-file for the global-file
334     if (globalFile) then
335     C We can not do this operation using threads (yet) because of the
336     C "barrier" at the next step. The barrier could be removed but
337     C at the cost of "safe" distributed I/O.
338     if (nThreads.NE.1) then
339     write(msgbuf,'(a,a)')
340     & ' MDSWRITEFIELD: A threads version of this routine',
341     & ' does not exist.'
342     call print_message( msgbuf, standardmessageunit,
343     & SQUEEZE_RIGHT , mythid)
344     write(msgbuf,'(a)')
345     & ' MDSWRITEFIELD: This needs to be fixed...'
346     call print_message( msgbuf, standardmessageunit,
347     & SQUEEZE_RIGHT , mythid)
348     write(msgbuf,'(a,i3.2)')
349     & ' MDSWRITEFIELD: nThreads = ',nThreads
350     call print_message( msgbuf, standardmessageunit,
351     & SQUEEZE_RIGHT , mythid)
352     write(msgbuf,'(a)')
353     & ' MDSWRITEFIELD: Stopping because you are using threads'
354     call print_error( msgbuf, mythid )
355     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
356     endif
357     C We put a barrier here to ensure that all processes have finished
358     C writing their data before we update the meta-file
359     _BARRIER
360     write(metaFName(1:80),'(2a)') fName(1:IL),'.meta'
361     dimList(1,1)=Nx
362     dimList(2,1)=1
363     dimList(3,1)=Nx
364     dimList(1,2)=Ny
365     dimList(2,2)=1
366     dimList(3,2)=Ny
367     dimList(1,3)=Nr
368     dimList(2,3)=1
369     dimList(3,3)=Nr
370     ndims=3
371     if (nNz .EQ. 1) ndims=2
372     call MDSWRITEMETA( metaFName, dataFName,
373     & filePrec, ndims, dimList, irecord, myIter, mythid )
374     fileIsOpen=.TRUE.
375     endif
376    
377     _END_MASTER( myThid )
378 dimitri 1.2
379     #ifdef ALLOW_USE_MPI
380     C endif useSingleCpuIO
381     endif
382     #endif /* ALLOW_USE_MPI */
383 adcroft 1.1
384     C ------------------------------------------------------------------
385     return
386     end

  ViewVC Help
Powered by ViewVC 1.1.22