/[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.4 - (hide annotations) (download)
Thu Oct 9 04:19:19 2003 UTC (20 years, 7 months ago) by edhill
Branch: MAIN
CVS Tags: checkpoint51k_post, checkpoint52l_pre, hrcube4, hrcube5, checkpoint52d_pre, checkpoint52j_pre, checkpoint51o_pre, checkpoint54d_post, checkpoint54e_post, checkpoint51l_post, checkpoint52l_post, checkpoint52k_post, checkpoint55, checkpoint54, checkpoint53, checkpoint52, checkpoint52f_post, checkpoint54f_post, checkpoint51t_post, checkpoint51n_post, checkpoint52i_pre, hrcube_1, hrcube_2, hrcube_3, checkpoint51s_post, checkpoint55c_post, checkpoint52e_pre, checkpoint52e_post, checkpoint51n_pre, checkpoint53d_post, checkpoint52b_pre, checkpoint54b_post, checkpoint51l_pre, checkpoint52m_post, checkpoint55g_post, checkpoint51q_post, checkpoint52b_post, checkpoint52c_post, checkpoint52f_pre, checkpoint55d_post, checkpoint54a_pre, checkpoint53c_post, checkpoint55d_pre, checkpoint54a_post, checkpoint51r_post, checkpoint51i_post, checkpoint55b_post, checkpoint53a_post, checkpoint55f_post, checkpoint52d_post, checkpoint53g_post, checkpoint52a_pre, checkpoint52i_post, checkpoint52h_pre, checkpoint53f_post, checkpoint52j_post, branch-netcdf, checkpoint52n_post, checkpoint53b_pre, checkpoint55a_post, checkpoint51o_post, checkpoint53b_post, checkpoint52a_post, ecco_c52_e35, checkpoint51m_post, checkpoint53d_pre, checkpoint55e_post, checkpoint54c_post, checkpoint51p_post, checkpoint51u_post
Branch point for: branch-nonh, tg2-branch, netcdf-sm0, checkpoint51n_branch
Changes since 1.3: +2 -16 lines 
 o first check-in for the "branch-genmake2" merge
 o verification suite as run on shelley (gcc 3.2.2):

Wed Oct  8 23:42:29 EDT 2003
                T           S           U           V
G D M    c        m  s        m  s        m  s        m  s
E p a R  g  m  m  e  .  m  m  e  .  m  m  e  .  m  m  e  .
N n k u  2  i  a  a  d  i  a  a  d  i  a  a  d  i  a  a  d
2 d e n  d  n  x  n  .  n  x  n  .  n  x  n  .  n  x  n  .

OPTFILE=NONE

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