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

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

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

Revision 1.3 - (hide annotations) (download)
Fri Dec 14 18:56:01 2001 UTC (22 years, 5 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint46n_post, checkpoint47e_post, checkpoint46l_post, checkpoint46g_pre, checkpoint47c_post, checkpoint50c_post, checkpoint46f_post, checkpoint48e_post, checkpoint50g_post, checkpoint46b_post, checkpoint43a-release1mods, checkpoint44g_post, checkpoint48c_post, checkpoint48i_post, checkpoint46l_pre, checkpoint50d_pre, chkpt44d_post, checkpoint51, checkpoint50d_post, checkpoint50b_pre, checkpoint44e_pre, checkpoint48b_post, checkpoint48c_pre, checkpoint48d_pre, checkpoint47i_post, checkpoint47d_post, checkpoint46d_pre, checkpoint48d_post, release1-branch_tutorials, checkpoint48f_post, checkpoint45d_post, checkpoint46j_pre, checkpoint47d_pre, chkpt44a_post, checkpoint44h_pre, checkpoint48h_post, checkpoint51b_pre, checkpoint46a_post, checkpoint47g_post, chkpt44c_post, checkpoint46j_post, checkpoint46k_post, checkpoint46b_pre, chkpt44c_pre, checkpoint45a_post, checkpoint50f_post, checkpoint50a_post, checkpoint50f_pre, checkpoint44e_post, checkpoint47a_post, checkpoint46e_pre, checkpoint45b_post, release1-branch-end, release1_final_v1, checkpoint51b_post, checkpoint46c_pre, checkpoint44f_post, checkpoint47b_post, checkpoint44b_post, checkpoint46h_pre, checkpoint46m_post, checkpoint46a_pre, checkpoint50c_pre, checkpoint45c_post, checkpoint44h_post, checkpoint46g_post, checkpoint46i_post, checkpoint50h_post, checkpoint50e_pre, checkpoint50i_post, checkpoint48a_post, checkpoint47j_post, branch-exfmods-tag, checkpoint47f_post, checkpoint50e_post, chkpt44a_pre, checkpoint46c_post, checkpoint46e_post, checkpoint44b_pre, checkpoint46, checkpoint47, checkpoint44, checkpoint45, checkpoint48, checkpoint49, checkpoint46h_post, checkpoint50, checkpoint47h_post, checkpoint44f_pre, checkpoint46d_post, checkpoint50b_post, release1-branch_branchpoint, checkpoint51a_post, checkpoint48g_post
Branch point for: branch-exfmods-curt, release1_final, release1-branch
Changes since 1.2: +55 -55 lines 
o convert from DOS to UNIX
o removed overlaps from segments
o bug fix (reported by V. Thierry) for global read/write:
  iG,jG,irec, wrongly computed for yz case
  (were identical to xz case)
1 heimbach 1.3 C $Header: /u/gcmpack/development/heimbach/ecco_env/pkg/mdsio/mdsio_slice.F,v 1.3 2001/12/14 17:36:32 heimbach Exp $
2 adcroft 1.2
3     #include "CPP_OPTIONS.h"
4    
5     #undef SAFE_IO
6    
7     #ifdef SAFE_IO
8     #define _NEW_STATUS 'new'
9     #else
10     #define _NEW_STATUS 'unknown'
11     #endif
12    
13     C=======================================================================
14     SUBROUTINE MDSREADFIELDXZ(
15     I fName,
16     I filePrec,
17     I arrType,
18     I nNz,
19     | arr,
20     I irecord,
21     I myThid )
22     C
23     C Arguments:
24     C
25     C fName string base name for file to read
26     C filePrec integer number of bits per word in file (32 or 64)
27     C arrType char(2) declaration of "arr": either "RS" or "RL"
28     C nNz integer size of third dimension: normally either 1 or Nr
29     C arr RS/RL array to read into, arr(:,:,nNz,:,:)
30     C irecord integer record number to read
31     C myThid integer thread identifier
32     C
33     C MDSREADFIELD first checks to see if the file "fName" exists, then
34     C if the file "fName.data" exists and finally the tiled files of the
35     C form "fName.xxx.yyy.data" exist.
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".
40     C This routine reads vertical slices (X-Z) including the overlap region.
41     C irecord is the record number to be read and must be >= 1.
42     C The file data is stored in arr *but* the overlaps are *not* updated.
43     C
44     C Created: 06/03/00 spk@ocean.mit.edu
45     C
46    
47     implicit none
48     C Global variables / common blocks
49     #include "SIZE.h"
50     #include "EEPARAMS.h"
51     #include "PARAMS.h"
52    
53     C Routine arguments
54     character*(*) fName
55     integer filePrec
56     character*(2) arrType
57     integer nNz
58     Real arr(*)
59     integer irecord
60     integer myThid
61     C Functions
62     integer ILNBLNK
63     integer MDS_RECLEN
64     C Local variables
65     character*(80) dataFName
66     integer iG,jG,irec,bi,bj,k,dUnit,IL
67     logical exst
68 heimbach 1.3 Real*4 r4seg(sNx)
69     Real*8 r8seg(sNx)
70 adcroft 1.2 logical globalFile,fileIsOpen
71     integer length_of_rec
72     character*(max_len_mbuf) msgbuf
73     C ------------------------------------------------------------------
74    
75     C Only do I/O if I am the master thread
76     _BEGIN_MASTER( myThid )
77    
78     C Record number must be >= 1
79     if (irecord .LT. 1) then
80     write(msgbuf,'(a,i9.8)')
81     & ' MDSREADFIELDXZ: argument irecord = ',irecord
82     call print_message( msgbuf, standardmessageunit,
83     & SQUEEZE_RIGHT , mythid)
84     write(msgbuf,'(a)')
85     & ' MDSREADFIELDXZ: Invalid value for irecord'
86     call print_error( msgbuf, mythid )
87     stop 'ABNORMAL END: S/R MDSREADFIELDXZ'
88     endif
89    
90     C Assume nothing
91     globalFile = .FALSE.
92     fileIsOpen = .FALSE.
93     IL=ILNBLNK( fName )
94    
95     C Assign a free unit number as the I/O channel for this routine
96     call MDSFINDUNIT( dUnit, mythid )
97    
98     C Check first for global file with simple name (ie. fName)
99     dataFName = fName
100     inquire( file=dataFname, exist=exst )
101     if (exst) then
102     write(msgbuf,'(a,a)')
103     & ' MDSREADFIELDXZ: opening global file: ',dataFName
104     call print_message( msgbuf, standardmessageunit,
105     & SQUEEZE_RIGHT , mythid)
106     globalFile = .TRUE.
107     endif
108    
109     C If negative check for global file with MDS name (ie. fName.data)
110     if (.NOT. globalFile) then
111     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
112     inquire( file=dataFname, exist=exst )
113     if (exst) then
114     write(msgbuf,'(a,a)')
115     & ' MDSREADFIELDXZ: opening global file: ',dataFName
116     call print_message( msgbuf, standardmessageunit,
117     & SQUEEZE_RIGHT , mythid)
118     globalFile = .TRUE.
119     endif
120     endif
121    
122     C If we are reading from a global file then we open it here
123     if (globalFile) then
124 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
125 adcroft 1.2 open( dUnit, file=dataFName, status='old',
126     & access='direct', recl=length_of_rec )
127     fileIsOpen=.TRUE.
128     endif
129    
130     C Loop over all tiles
131     do bj=1,nSy
132     do bi=1,nSx
133     C If we are reading from a tiled MDS file then we open each one here
134     if (.NOT. globalFile) then
135     iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
136     jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
137     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
138     & fName(1:IL),'.',iG,'.',jG,'.data'
139     inquire( file=dataFname, exist=exst )
140     C Of course, we only open the file if the tile is "active"
141     C (This is a place-holder for the active/passive mechanism
142     if (exst) then
143     write(msgbuf,'(a,a)')
144     & ' MDSREADFIELDXZ: opening file: ',dataFName
145     call print_message( msgbuf, standardmessageunit,
146     & SQUEEZE_RIGHT , mythid)
147 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
148 adcroft 1.2 open( dUnit, file=dataFName, status='old',
149     & access='direct', recl=length_of_rec )
150     fileIsOpen=.TRUE.
151     else
152     fileIsOpen=.FALSE.
153     write(msgbuf,'(a,a)')
154     & ' MDSREADFIELDXZ: filename: ',dataFName
155     call print_message( msgbuf, standardmessageunit,
156     & SQUEEZE_RIGHT , mythid)
157     write(msgbuf,'(a)')
158     & ' MDSREADFIELDXZ: File does not exist'
159     call print_error( msgbuf, mythid )
160     stop 'ABNORMAL END: S/R MDSREADFIELDXZ'
161     endif
162     endif
163    
164     if (fileIsOpen) then
165     do k=1,nNz
166     if (globalFile) then
167     iG = myXGlobalLo-1 + (bi-1)*sNx
168     jG = (myYGlobalLo-1)/sNy + (bj-1)
169     irec=1 + INT(iG/sNx) + nSx*nPx*jG + nSx*nPx*nSy*nPy*(k-1)
170     & + nSx*nPx*nSy*nPy*nNz*(irecord-1)
171     else
172     iG = 0
173     jG = 0
174     irec=k + nNz*(irecord-1)
175     endif
176     if (filePrec .eq. precFloat32) then
177     read(dUnit,rec=irec) r4seg
178     #ifdef _BYTESWAPIO
179 heimbach 1.3 call MDS_BYTESWAPR4(sNx,r4seg)
180 adcroft 1.2 #endif
181     if (arrType .eq. 'RS') then
182     call MDS_SEG4toRS_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r4seg,arr)
183     elseif (arrType .eq. 'RL') then
184     call MDS_SEG4toRL_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r4seg,arr)
185     else
186     write(msgbuf,'(a)')
187     & ' MDSREADFIELDXZ: illegal value for arrType'
188     call print_error( msgbuf, mythid )
189     stop 'ABNORMAL END: S/R MDSREADFIELDXZ'
190     endif
191     elseif (filePrec .eq. precFloat64) then
192     read(dUnit,rec=irec) r8seg
193     #ifdef _BYTESWAPIO
194 heimbach 1.3 call MDS_BYTESWAPR8( sNx, r8seg )
195 adcroft 1.2 #endif
196     if (arrType .eq. 'RS') then
197     call MDS_SEG8toRS_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r8seg,arr)
198     elseif (arrType .eq. 'RL') then
199     call MDS_SEG8toRL_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r8seg,arr)
200     else
201     write(msgbuf,'(a)')
202     & ' MDSREADFIELDXZ: illegal value for arrType'
203     call print_error( msgbuf, mythid )
204     stop 'ABNORMAL END: S/R MDSREADFIELDXZ'
205     endif
206     else
207     write(msgbuf,'(a)')
208     & ' MDSREADFIELDXZ: illegal value for filePrec'
209     call print_error( msgbuf, mythid )
210     stop 'ABNORMAL END: S/R MDSREADFIELDXZ'
211     endif
212     C End of k loop
213     enddo
214     if (.NOT. globalFile) then
215     close( dUnit )
216     fileIsOpen = .FALSE.
217     endif
218     endif
219     C End of bi,bj loops
220     enddo
221     enddo
222    
223     C If global file was opened then close it
224     if (fileIsOpen .AND. globalFile) then
225     close( dUnit )
226     fileIsOpen = .FALSE.
227     endif
228    
229     _END_MASTER( myThid )
230    
231     C ------------------------------------------------------------------
232     return
233     end
234     C=======================================================================
235    
236     C=======================================================================
237     SUBROUTINE MDSREADFIELDYZ(
238     I fName,
239     I filePrec,
240     I arrType,
241     I nNz,
242     | arr,
243     I irecord,
244     I myThid )
245     C
246     C Arguments:
247     C
248     C fName string base name for file to read
249     C filePrec integer number of bits per word in file (32 or 64)
250     C arrType char(2) declaration of "arr": either "RS" or "RL"
251     C nNz integer size of third dimension: normally either 1 or Nr
252     C arr RS/RL array to read into, arr(:,:,nNz,:,:)
253     C irecord integer record number to read
254     C myThid integer thread identifier
255     C
256     C MDSREADFIELD first checks to see if the file "fName" exists, then
257     C if the file "fName.data" exists and finally the tiled files of the
258     C form "fName.xxx.yyy.data" exist.
259     C The precision of the file is decsribed by filePrec, set either
260     C to floatPrec32 or floatPrec64. The precision or declaration of
261     C the array argument must be consistently described by the char*(2)
262     C string arrType, either "RS" or "RL".
263     C This routine reads vertical slices (Y-Z) including overlap regions.
264     C irecord is the record number to be read and must be >= 1.
265     C The file data is stored in arr *but* the overlaps are *not* updated.
266     C
267     C Created: 06/03/00 spk@ocean.mit.edu
268     C
269    
270     implicit none
271     C Global variables / common blocks
272     #include "SIZE.h"
273     #include "EEPARAMS.h"
274     #include "PARAMS.h"
275    
276     C Routine arguments
277     character*(*) fName
278     integer filePrec
279     character*(2) arrType
280     integer nNz
281     Real arr(*)
282     integer irecord
283     integer myThid
284     C Functions
285     integer ILNBLNK
286     integer MDS_RECLEN
287     C Local variables
288     character*(80) dataFName
289     integer iG,jG,irec,bi,bj,k,dUnit,IL
290     logical exst
291 heimbach 1.3 Real*4 r4seg(sNy)
292     Real*8 r8seg(sNy)
293 adcroft 1.2 logical globalFile,fileIsOpen
294     integer length_of_rec
295     character*(max_len_mbuf) msgbuf
296     C ------------------------------------------------------------------
297    
298     C Only do I/O if I am the master thread
299     _BEGIN_MASTER( myThid )
300    
301     C Record number must be >= 1
302     if (irecord .LT. 1) then
303     write(msgbuf,'(a,i9.8)')
304     & ' MDSREADFIELDYZ: argument irecord = ',irecord
305     call print_message( msgbuf, standardmessageunit,
306     & SQUEEZE_RIGHT , mythid)
307     write(msgbuf,'(a)')
308     & ' MDSREADFIELDYZ: Invalid value for irecord'
309     call print_error( msgbuf, mythid )
310     stop 'ABNORMAL END: S/R MDSREADFIELDYZ'
311     endif
312    
313     C Assume nothing
314     globalFile = .FALSE.
315     fileIsOpen = .FALSE.
316     IL=ILNBLNK( fName )
317    
318     C Assign a free unit number as the I/O channel for this routine
319     call MDSFINDUNIT( dUnit, mythid )
320    
321     C Check first for global file with simple name (ie. fName)
322     dataFName = fName
323     inquire( file=dataFname, exist=exst )
324     if (exst) then
325     write(msgbuf,'(a,a)')
326     & ' MDSREADFIELDYZ: opening global file: ',dataFName
327     call print_message( msgbuf, standardmessageunit,
328     & SQUEEZE_RIGHT , mythid)
329     globalFile = .TRUE.
330     endif
331    
332     C If negative check for global file with MDS name (ie. fName.data)
333     if (.NOT. globalFile) then
334     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
335     inquire( file=dataFname, exist=exst )
336     if (exst) then
337     write(msgbuf,'(a,a)')
338     & ' MDSREADFIELDYZ: opening global file: ',dataFName
339     call print_message( msgbuf, standardmessageunit,
340     & SQUEEZE_RIGHT , mythid)
341     globalFile = .TRUE.
342     endif
343     endif
344    
345     C If we are reading from a global file then we open it here
346     if (globalFile) then
347 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNy, mythid )
348 adcroft 1.2 open( dUnit, file=dataFName, status='old',
349     & access='direct', recl=length_of_rec )
350     fileIsOpen=.TRUE.
351     endif
352    
353     C Loop over all tiles
354     do bj=1,nSy
355     do bi=1,nSx
356     C If we are reading from a tiled MDS file then we open each one here
357     if (.NOT. globalFile) then
358     iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
359     jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
360     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
361     & fName(1:IL),'.',iG,'.',jG,'.data'
362     inquire( file=dataFname, exist=exst )
363     C Of course, we only open the file if the tile is "active"
364     C (This is a place-holder for the active/passive mechanism
365     if (exst) then
366     write(msgbuf,'(a,a)')
367     & ' MDSREADFIELDYZ: opening file: ',dataFName
368     call print_message( msgbuf, standardmessageunit,
369     & SQUEEZE_RIGHT , mythid)
370 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNy, mythid )
371 adcroft 1.2 open( dUnit, file=dataFName, status='old',
372     & access='direct', recl=length_of_rec )
373     fileIsOpen=.TRUE.
374     else
375     fileIsOpen=.FALSE.
376     write(msgbuf,'(a,a)')
377     & ' MDSREADFIELDYZ: filename: ',dataFName
378     call print_message( msgbuf, standardmessageunit,
379     & SQUEEZE_RIGHT , mythid)
380     write(msgbuf,'(a)')
381     & ' MDSREADFIELDYZ: File does not exist'
382     call print_error( msgbuf, mythid )
383     stop 'ABNORMAL END: S/R MDSREADFIELDYZ'
384     endif
385     endif
386    
387     if (fileIsOpen) then
388     do k=1,nNz
389     if (globalFile) then
390 heimbach 1.3 iG = (myXGlobalLo-1)/sNx + (bi-1)
391     jG = myYGlobalLo-1 + (bj-1)*sNy
392     irec=1 + INT(jG/sNy) + nSy*nPy*iG + nSx*nPx*nSy*nPy*(k-1)
393 adcroft 1.2 & + nSx*nPx*nSy*nPy*nNz*(irecord-1)
394     else
395     iG = 0
396     jG = 0
397     irec=k + nNz*(irecord-1)
398     endif
399     if (filePrec .eq. precFloat32) then
400     read(dUnit,rec=irec) r4seg
401     #ifdef _BYTESWAPIO
402 heimbach 1.3 call MDS_BYTESWAPR4(sNy,r4seg)
403 adcroft 1.2 #endif
404     if (arrType .eq. 'RS') then
405     call MDS_SEG4toRS_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r4seg,arr)
406     elseif (arrType .eq. 'RL') then
407     call MDS_SEG4toRL_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r4seg,arr)
408     else
409     write(msgbuf,'(a)')
410     & ' MDSREADFIELDYZ: illegal value for arrType'
411     call print_error( msgbuf, mythid )
412     stop 'ABNORMAL END: S/R MDSREADFIELDYZ'
413     endif
414     elseif (filePrec .eq. precFloat64) then
415     read(dUnit,rec=irec) r8seg
416     #ifdef _BYTESWAPIO
417 heimbach 1.3 call MDS_BYTESWAPR8( sNy, r8seg )
418 adcroft 1.2 #endif
419     if (arrType .eq. 'RS') then
420     call MDS_SEG8toRS_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r8seg,arr)
421     elseif (arrType .eq. 'RL') then
422     call MDS_SEG8toRL_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r8seg,arr)
423     else
424     write(msgbuf,'(a)')
425     & ' MDSREADFIELDYZ: illegal value for arrType'
426     call print_error( msgbuf, mythid )
427     stop 'ABNORMAL END: S/R MDSREADFIELDYZ'
428     endif
429     else
430     write(msgbuf,'(a)')
431     & ' MDSREADFIELDYZ: illegal value for filePrec'
432     call print_error( msgbuf, mythid )
433     stop 'ABNORMAL END: S/R MDSREADFIELDYZ'
434     endif
435     C End of k loop
436     enddo
437     if (.NOT. globalFile) then
438     close( dUnit )
439     fileIsOpen = .FALSE.
440     endif
441     endif
442     C End of bi,bj loops
443     enddo
444     enddo
445    
446     C If global file was opened then close it
447     if (fileIsOpen .AND. globalFile) then
448     close( dUnit )
449     fileIsOpen = .FALSE.
450     endif
451    
452     _END_MASTER( myThid )
453    
454     C ------------------------------------------------------------------
455     return
456     end
457     C=======================================================================
458    
459     C=======================================================================
460     SUBROUTINE MDSWRITEFIELDXZ(
461     I fName,
462     I filePrec,
463     I globalFile,
464     I arrType,
465     I nNz,
466     I arr,
467     I irecord,
468     I myIter,
469     I myThid )
470     C
471     C Arguments:
472     C
473     C fName string base name for file to written
474     C filePrec integer number of bits per word in file (32 or 64)
475     C globalFile logical selects between writing a global or tiled file
476     C C arrType char(2) declaration of "arr": either "RS" or "RL"
477     C nNz integer size of second dimension: Nr
478     C arr RL array to write, arr(:,nNz,:,:)
479     C irecord integer record number to read
480     C myIter integer time step number
481     C myThid integer thread identifier
482     C
483     C MDSWRITEFIELDXZ creates either a file of the form "fName.data"
484     C if the logical flag "globalFile" is set true. Otherwise
485     C it creates MDS tiled files of the form "fName.xxx.yyy.data".
486     C The precision of the file is decsribed by filePrec, set either
487     C to floatPrec32 or floatPrec64. The precision or declaration of
488     C the array argument must be consistently described by the char*(2)
489     C string arrType, either "RS" or "RL".
490     C This routine writes vertical slices (X-Z) including overlap regions.
491     C irecord is the record number to be read and must be >= 1.
492     C NOTE: It is currently assumed that
493     C the highest record number in the file was the last record written.
494     C
495     C Modified: 06/02/00 spk@ocean.mit.edu
496    
497     implicit none
498     C Global variables / common blocks
499     #include "SIZE.h"
500     #include "EEPARAMS.h"
501     #include "PARAMS.h"
502    
503     C Routine arguments
504     character*(*) fName
505     integer filePrec
506     logical globalFile
507     character*(2) arrType
508     integer nNz
509     Real arr(*)
510     integer irecord
511     integer myIter
512     integer myThid
513     C Functions
514     integer ILNBLNK
515     integer MDS_RECLEN
516     C Local variables
517     character*(80) dataFName
518     integer iG,jG,irec,bi,bj,k,dUnit,IL
519 heimbach 1.3 Real*4 r4seg(sNx)
520     Real*8 r8seg(sNx)
521 adcroft 1.2 integer length_of_rec
522     logical fileIsOpen
523     character*(max_len_mbuf) msgbuf
524     C ------------------------------------------------------------------
525    
526     C Only do I/O if I am the master thread
527     _BEGIN_MASTER( myThid )
528    
529     C Record number must be >= 1
530     if (irecord .LT. 1) then
531     write(msgbuf,'(a,i9.8)')
532     & ' MDSWRITEFIELDXZ: argument irecord = ',irecord
533     call print_message( msgbuf, standardmessageunit,
534     & SQUEEZE_RIGHT , mythid)
535     write(msgbuf,'(a)')
536     & ' MDSWRITEFIELDXZ: invalid value for irecord'
537     call print_error( msgbuf, mythid )
538     stop 'ABNORMAL END: S/R MDSWRITEFIELDXZ'
539     endif
540    
541     C Assume nothing
542     fileIsOpen=.FALSE.
543     IL=ILNBLNK( fName )
544    
545     C Assign a free unit number as the I/O channel for this routine
546     call MDSFINDUNIT( dUnit, mythid )
547    
548     C If we are writing to a global file then we open it here
549     if (globalFile) then
550     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
551     if (irecord .EQ. 1) then
552 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
553 adcroft 1.2 open( dUnit, file=dataFName, status=_NEW_STATUS,
554     & access='direct', recl=length_of_rec )
555     fileIsOpen=.TRUE.
556     else
557 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
558 adcroft 1.2 open( dUnit, file=dataFName, status='old',
559     & access='direct', recl=length_of_rec )
560     fileIsOpen=.TRUE.
561     endif
562     endif
563    
564     C Loop over all tiles
565     do bj=1,nSy
566     do bi=1,nSx
567     C If we are writing to a tiled MDS file then we open each one here
568     if (.NOT. globalFile) then
569     iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
570     jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
571     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
572     & fName(1:IL),'.',iG,'.',jG,'.data'
573     if (irecord .EQ. 1) then
574 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
575 adcroft 1.2 open( dUnit, file=dataFName, status=_NEW_STATUS,
576     & access='direct', recl=length_of_rec )
577     fileIsOpen=.TRUE.
578     else
579 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
580 adcroft 1.2 open( dUnit, file=dataFName, status='old',
581     & access='direct', recl=length_of_rec )
582     fileIsOpen=.TRUE.
583     endif
584     endif
585     if (fileIsOpen) then
586     do k=1,nNz
587     if (globalFile) then
588     iG = myXGlobalLo-1 + (bi-1)*sNx
589     jG = (myYGlobalLo-1)/sNy + (bj-1)
590     irec=1 + INT(iG/sNx) + nSx*nPx*jG + nSx*nPx*nSy*nPy*(k-1)
591     & + nSx*nPx*nSy*nPy*nNz*(irecord-1)
592     else
593     iG = 0
594     jG = 0
595     irec=k + nNz*(irecord-1)
596     endif
597     if (filePrec .eq. precFloat32) then
598     if (arrType .eq. 'RS') then
599     call MDS_SEG4toRS_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r4seg,arr)
600     elseif (arrType .eq. 'RL') then
601     call MDS_SEG4toRL_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r4seg,arr)
602     else
603     write(msgbuf,'(a)')
604     & ' MDSWRITEFIELDXZ: illegal value for arrType'
605     call print_error( msgbuf, mythid )
606     stop 'ABNORMAL END: S/R MDSWRITEFIELDXZ'
607     endif
608     #ifdef _BYTESWAPIO
609 heimbach 1.3 call MDS_BYTESWAPR4(sNx,r4seg)
610 adcroft 1.2 #endif
611     write(dUnit,rec=irec) r4seg
612     elseif (filePrec .eq. precFloat64) then
613     if (arrType .eq. 'RS') then
614     call MDS_SEG8toRS_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r8seg,arr)
615     elseif (arrType .eq. 'RL') then
616     call MDS_SEG8toRL_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r8seg,arr)
617     else
618     write(msgbuf,'(a)')
619     & ' MDSWRITEFIELDXZ: illegal value for arrType'
620     call print_error( msgbuf, mythid )
621     stop 'ABNORMAL END: S/R MDSWRITEFIELDXZ'
622     endif
623     #ifdef _BYTESWAPIO
624 heimbach 1.3 call MDS_BYTESWAPR8( sNx, r8seg )
625 adcroft 1.2 #endif
626     write(dUnit,rec=irec) r8seg
627     else
628     write(msgbuf,'(a)')
629     & ' MDSWRITEFIELDXZ: illegal value for filePrec'
630     call print_error( msgbuf, mythid )
631     stop 'ABNORMAL END: S/R MDSWRITEFIELDXZ'
632     endif
633     C End of k loop
634     enddo
635     else
636     write(msgbuf,'(a)')
637     & ' MDSWRITEFIELDXZ: I should never get to this point'
638     call print_error( msgbuf, mythid )
639     stop 'ABNORMAL END: S/R MDSWRITEFIELDXZ'
640     endif
641     C If we were writing to a tiled MDS file then we close it here
642     if (fileIsOpen .AND. (.NOT. globalFile)) then
643     close( dUnit )
644     fileIsOpen = .FALSE.
645     endif
646     C End of bi,bj loops
647     enddo
648     enddo
649    
650     C If global file was opened then close it
651     if (fileIsOpen .AND. globalFile) then
652     close( dUnit )
653     fileIsOpen = .FALSE.
654     endif
655    
656     C We put a barrier here to ensure that all processes have finished
657     C writing their data before we update the meta-file
658     _BARRIER
659    
660     _END_MASTER( myThid )
661    
662     C ------------------------------------------------------------------
663     return
664     end
665     C=======================================================================
666    
667     C=======================================================================
668     SUBROUTINE MDSWRITEFIELDYZ(
669     I fName,
670     I filePrec,
671     I globalFile,
672     I arrType,
673     I nNz,
674     I arr,
675     I irecord,
676     I myIter,
677     I myThid )
678     C
679     C Arguments:
680     C
681     C fName string base name for file to written
682     C filePrec integer number of bits per word in file (32 or 64)
683     C globalFile logical selects between writing a global or tiled file
684     C C arrType char(2) declaration of "arr": either "RS" or "RL"
685     C nNz integer size of second dimension: Nr
686     C arr RL array to write, arr(:,nNz,:,:)
687     C irecord integer record number to read
688     C myIter integer time step number
689     C myThid integer thread identifier
690     C
691     C MDSWRITEFIELDYZ creates either a file of the form "fName.data"
692     C if the logical flag "globalFile" is set true. Otherwise
693     C it creates MDS tiled files of the form "fName.xxx.yyy.data".
694     C The precision of the file is decsribed by filePrec, set either
695     C to floatPrec32 or floatPrec64. The precision or declaration of
696     C the array argument must be consistently described by the char*(2)
697     C string arrType, either "RS" or "RL".
698     C This routine writes vertical slices (Y-Z) including overlap regions.
699     C irecord is the record number to be read and must be >= 1.
700     C NOTE: It is currently assumed that
701     C the highest record number in the file was the last record written.
702     C
703     C Modified: 06/02/00 spk@ocean.mit.edu
704    
705    
706     implicit none
707     C Global variables / common blocks
708     #include "SIZE.h"
709     #include "EEPARAMS.h"
710     #include "PARAMS.h"
711    
712     C Routine arguments
713     character*(*) fName
714     integer filePrec
715     logical globalFile
716     character*(2) arrType
717     integer nNz
718     Real arr(*)
719     integer irecord
720     integer myIter
721     integer myThid
722     C Functions
723     integer ILNBLNK
724     integer MDS_RECLEN
725     C Local variables
726     character*(80) dataFName
727     integer iG,jG,irec,bi,bj,k,dUnit,IL
728 heimbach 1.3 Real*4 r4seg(sNy)
729     Real*8 r8seg(sNy)
730 adcroft 1.2 integer length_of_rec
731     logical fileIsOpen
732     character*(max_len_mbuf) msgbuf
733     C ------------------------------------------------------------------
734    
735     C Only do I/O if I am the master thread
736     _BEGIN_MASTER( myThid )
737    
738     C Record number must be >= 1
739     if (irecord .LT. 1) then
740     write(msgbuf,'(a,i9.8)')
741     & ' MDSWRITEFIELDYZ: argument irecord = ',irecord
742     call print_message( msgbuf, standardmessageunit,
743     & SQUEEZE_RIGHT , mythid)
744     write(msgbuf,'(a)')
745     & ' MDSWRITEFIELDYZ: invalid value for irecord'
746     call print_error( msgbuf, mythid )
747     stop 'ABNORMAL END: S/R MDSWRITEFIELDYZ'
748     endif
749    
750     C Assume nothing
751     fileIsOpen=.FALSE.
752     IL=ILNBLNK( fName )
753    
754     C Assign a free unit number as the I/O channel for this routine
755     call MDSFINDUNIT( dUnit, mythid )
756    
757     C If we are writing to a global file then we open it here
758     if (globalFile) then
759     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
760     if (irecord .EQ. 1) then
761 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNy, mythid )
762 adcroft 1.2 open( dUnit, file=dataFName, status=_NEW_STATUS,
763     & access='direct', recl=length_of_rec )
764     fileIsOpen=.TRUE.
765     else
766 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNy, mythid )
767 adcroft 1.2 open( dUnit, file=dataFName, status='old',
768     & access='direct', recl=length_of_rec )
769     fileIsOpen=.TRUE.
770     endif
771     endif
772    
773     C Loop over all tiles
774     do bj=1,nSy
775     do bi=1,nSx
776     C If we are writing to a tiled MDS file then we open each one here
777     if (.NOT. globalFile) then
778     iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
779     jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
780     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
781     & fName(1:IL),'.',iG,'.',jG,'.data'
782     if (irecord .EQ. 1) then
783 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNy, mythid )
784 adcroft 1.2 open( dUnit, file=dataFName, status=_NEW_STATUS,
785     & access='direct', recl=length_of_rec )
786     fileIsOpen=.TRUE.
787     else
788 heimbach 1.3 length_of_rec=MDS_RECLEN( filePrec, sNy, mythid )
789 adcroft 1.2 open( dUnit, file=dataFName, status='old',
790     & access='direct', recl=length_of_rec )
791     fileIsOpen=.TRUE.
792     endif
793     endif
794     if (fileIsOpen) then
795     do k=1,nNz
796     if (globalFile) then
797 heimbach 1.3 iG = (myXGlobalLo-1)/sNx + (bi-1)
798     jG = myYGlobalLo-1 + (bj-1)*sNy
799     irec=1 + INT(jG/sNy) + nSy*nPy*iG + nSx*nPx*nSy*nPy*(k-1)
800 adcroft 1.2 & + nSx*nPx*nSy*nPy*nNz*(irecord-1)
801     else
802     iG = 0
803     jG = 0
804     irec=k + nNz*(irecord-1)
805     endif
806     if (filePrec .eq. precFloat32) then
807     if (arrType .eq. 'RS') then
808     call MDS_SEG4toRS_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r4seg,arr)
809     elseif (arrType .eq. 'RL') then
810     call MDS_SEG4toRL_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r4seg,arr)
811     else
812     write(msgbuf,'(a)')
813     & ' MDSWRITEFIELDYZ: illegal value for arrType'
814     call print_error( msgbuf, mythid )
815     stop 'ABNORMAL END: S/R MDSWRITEFIELDYZ'
816     endif
817     #ifdef _BYTESWAPIO
818 heimbach 1.3 call MDS_BYTESWAPR4(sNy,r4seg)
819 adcroft 1.2 #endif
820     write(dUnit,rec=irec) r4seg
821     elseif (filePrec .eq. precFloat64) then
822     if (arrType .eq. 'RS') then
823     call MDS_SEG8toRS_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r8seg,arr)
824     elseif (arrType .eq. 'RL') then
825     call MDS_SEG8toRL_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r8seg,arr)
826     else
827     write(msgbuf,'(a)')
828     & ' MDSWRITEFIELDYZ: illegal value for arrType'
829     call print_error( msgbuf, mythid )
830     stop 'ABNORMAL END: S/R MDSWRITEFIELDYZ'
831     endif
832     #ifdef _BYTESWAPIO
833 heimbach 1.3 call MDS_BYTESWAPR8( sNy, r8seg )
834 adcroft 1.2 #endif
835     write(dUnit,rec=irec) r8seg
836     else
837     write(msgbuf,'(a)')
838     & ' MDSWRITEFIELDYZ: illegal value for filePrec'
839     call print_error( msgbuf, mythid )
840     stop 'ABNORMAL END: S/R MDSWRITEFIELDYZ'
841     endif
842     C End of k loop
843     enddo
844     else
845     write(msgbuf,'(a)')
846     & ' MDSWRITEFIELDYZ: I should never get to this point'
847     call print_error( msgbuf, mythid )
848     stop 'ABNORMAL END: S/R MDSWRITEFIELDYZ'
849     endif
850     C If we were writing to a tiled MDS file then we close it here
851     if (fileIsOpen .AND. (.NOT. globalFile)) then
852     close( dUnit )
853     fileIsOpen = .FALSE.
854     endif
855     C End of bi,bj loops
856     enddo
857     enddo
858    
859     C If global file was opened then close it
860     if (fileIsOpen .AND. globalFile) then
861     close( dUnit )
862     fileIsOpen = .FALSE.
863     endif
864    
865     C We put a barrier here to ensure that all processes have finished
866     C writing their data before we update the meta-file
867     _BARRIER
868    
869     _END_MASTER( myThid )
870    
871     C ------------------------------------------------------------------
872     return
873     end
874     C=======================================================================
875    
876     C=======================================================================
877     subroutine MDS_SEG4toRL_2D(sn,ol,nNz,bi,bj,k,copyTo,seg,arr)
878     C IN:
879     C sn,ol,nNz integer - size of 'arr'. sn,ol can be sNx,oLx OR sNy,oLy
880     C k,bi,bj, integer - indices to array "arr"
881     C copyTo logical - flag to indicate tranfer direction.
882     C .TRUE.: seg -> arr, .FALSE.: arr -> seg
883     C seg Real*4 - 1-D vector of length sn
884     C OUT:
885     C arr _RL - model vertical slice (array)
886     C
887     C Created: 06/03/00 spk@ocean.mit.edu
888    
889     implicit none
890     C Global variables / common blocks
891     #include "SIZE.h"
892    
893     C Arguments
894     integer sn,ol,nNz,bi,bj,k
895     logical copyTo
896 heimbach 1.3 Real*4 seg(sn)
897 adcroft 1.2 _RL arr(1-ol:sn+ol,nNz,nSx,nSy)
898    
899     C Local
900     integer ii
901     C ------------------------------------------------------------------
902     if (copyTo) then
903 heimbach 1.3 do ii=1,sn
904     arr(ii,k,bi,bj)=seg(ii)
905 adcroft 1.2 enddo
906     else
907 heimbach 1.3 do ii=1,sn
908     seg(ii)=arr(ii,k,bi,bj)
909 adcroft 1.2 enddo
910     endif
911     C ------------------------------------------------------------------
912     return
913     end
914     C=======================================================================
915    
916     C=======================================================================
917     subroutine MDS_SEG4toRS_2D(sn,ol,nNz,bi,bj,k,copyTo,seg,arr)
918     C IN:
919     C sn,ol,nNz integer - size of 'arr'. sn,ol can be sNx,oLx OR sNy,oLy
920     C k,bi,bj, integer - indices to array "arr"
921     C copyTo logical - flag to indicate tranfer direction.
922     C .TRUE.: seg -> arr, .FALSE.: arr -> seg
923     C seg Real*4 - 1-D vector of length sn
924     C OUT:
925     C arr _RS - model vertical slice (array)
926     C
927     C Created: 06/03/00 spk@ocean.mit.edu
928    
929     implicit none
930     C Global variables / common blocks
931     #include "SIZE.h"
932    
933     C Arguments
934     integer sn,ol,nNz,bi,bj,k
935     logical copyTo
936 heimbach 1.3 Real*4 seg(sn)
937 adcroft 1.2 _RS arr(1-ol:sn+ol,nNz,nSx,nSy)
938    
939     C Local
940     integer ii
941     C ------------------------------------------------------------------
942     if (copyTo) then
943 heimbach 1.3 do ii=1,sn
944     arr(ii,k,bi,bj)=seg(ii)
945 adcroft 1.2 enddo
946     else
947 heimbach 1.3 do ii=1,sn
948     seg(ii)=arr(ii,k,bi,bj)
949 adcroft 1.2 enddo
950     endif
951     C ------------------------------------------------------------------
952     return
953     end
954     C=======================================================================
955    
956     C=======================================================================
957     subroutine MDS_SEG8toRL_2D(sn,ol,nNz,bi,bj,k,copyTo,seg,arr)
958     C IN:
959     C sn,ol,nNz integer - size of 'arr'. sn,ol can be sNx,oLx OR sNy,oLy
960     C k,bi,bj, integer - indices to array "arr"
961     C copyTo logical - flag to indicate tranfer direction.
962     C .TRUE.: seg -> arr, .FALSE.: arr -> seg
963     C seg Real*8 - 1-D vector of length sn
964     C OUT:
965     C arr _RL - model vertical slice (array)
966     C
967     C Created: 06/03/00 spk@ocean.mit.edu
968    
969     implicit none
970     C Global variables / common blocks
971     #include "SIZE.h"
972    
973     C Arguments
974     integer sn,ol,nNz,bi,bj,k
975     logical copyTo
976 heimbach 1.3 Real*8 seg(sn)
977 adcroft 1.2 _RL arr(1-ol:sn+ol,nNz,nSx,nSy)
978    
979     C Local
980     integer ii
981     C ------------------------------------------------------------------
982     if (copyTo) then
983 heimbach 1.3 do ii=1,sn
984     arr(ii,k,bi,bj)=seg(ii)
985 adcroft 1.2 enddo
986     else
987 heimbach 1.3 do ii=1,sn
988     seg(ii)=arr(ii,k,bi,bj)
989 adcroft 1.2 enddo
990     endif
991     C ------------------------------------------------------------------
992     return
993     end
994     C=======================================================================
995    
996     C=======================================================================
997     subroutine MDS_SEG8toRS_2D(sn,ol,nNz,bi,bj,k,copyTo,seg,arr)
998     C IN:
999     C sn,ol,nNz integer - size of 'arr'. sn,ol can be sNx,oLx OR sNy,oLy
1000     C k,bi,bj, integer - indices to array "arr"
1001     C copyTo logical - flag to indicate tranfer direction.
1002     C .TRUE.: seg -> arr, .FALSE.: arr -> seg
1003     C seg Real*8 - 1-D vector of length sn
1004     C OUT:
1005     C arr _RS - model vertical slice (array)
1006     C
1007     C Created: 06/03/00 spk@ocean.mit.edu
1008    
1009     implicit none
1010     C Global variables / common blocks
1011     #include "SIZE.h"
1012    
1013     C Arguments
1014     integer sn,ol,nNz,bi,bj,k
1015     logical copyTo
1016 heimbach 1.3 Real*8 seg(sn)
1017 adcroft 1.2 _RS arr(1-ol:sn+ol,nNz,nSx,nSy)
1018    
1019     C Local
1020     integer ii
1021     C ------------------------------------------------------------------
1022     if (copyTo) then
1023 heimbach 1.3 do ii=1,sn
1024     arr(ii,k,bi,bj)=seg(ii)
1025 adcroft 1.2 enddo
1026     else
1027 heimbach 1.3 do ii=1,sn
1028     seg(ii)=arr(ii,k,bi,bj)
1029 adcroft 1.2 enddo
1030     endif
1031     C ------------------------------------------------------------------
1032     return
1033     end
1034     C=======================================================================
1035    
  ViewVC Help
Powered by ViewVC 1.1.22