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

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

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

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