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

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

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

revision 1.1 by adcroft, Tue Mar 6 15:28:54 2001 UTC revision 1.13 by jmc, Sat Nov 5 01:05:14 2005 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
 C $Name$  
2    
3  #include "MDSIO_OPTIONS.h"  #include "MDSIO_OPTIONS.h"
4    
5    C The five "public" routines supplied here are:
6    C
7    C MDSREADFIELD   - read model field from direct access global or tiled MDS file
8    C MDSWRITEFIELD  - write model field to direct access global or tiled MDS file
9    C MDSFINDUNIT    - returns an available (unused) I/O channel
10    C MDSREADVECTOR  - read vector from direct access global or tiled MDS file
11    C MDSWRITEVECTOR - write vector to direct access global or tiled MDS file
12    C
13    C all other routines are "private" to these utilities and ought
14    C not be accessed directly from the main code.
15    C
16    C Created:  03/16/99 adcroft@mit.edu
17    C Modified: 03/23/99 adcroft@mit.edu
18    C           To work with multiple records
19    C Modified: 03/29/99 eckert@mit.edu
20    C           Added arbitrary vector capability
21    C Modified: 07/27/99 eckert@mit.edu
22    C           Customized for state estimation (--> active_file_control.F)
23    C           this relates only to *mdsreadvector* and *mdswritevector*
24    C Modified: 07/28/99 eckert@mit.edu
25    C           inserted calls to *print_message* and *print_error*
26    C
27    C To be modified to work with MITgcmuv message routines.
28    
29  C=======================================================================  C=======================================================================
30        SUBROUTINE MDSREADFIELD_GL(        SUBROUTINE MDSREADFIELD_3D_GL(
31       I   fName,       I   fName,
32       I   filePrec,       I   filePrec,
33       I   arrType,       I   arrType,
# Line 38  C arr *but* the overlaps are *not* updat Line 61  C arr *but* the overlaps are *not* updat
61  C be called. This is because the routine is sometimes called from  C be called. This is because the routine is sometimes called from
62  C within a MASTER_THID region.  C within a MASTER_THID region.
63  C  C
64  C Created: 03/16/99 anonymous@nowhere.com  C Created: 03/16/99 adcroft@mit.edu
65    
66        implicit none        implicit none
67  C Global variables / common blocks  C Global variables / common blocks
68  #include "SIZE.h"  #include "SIZE.h"
69  #include "EEPARAMS.h"  #include "EEPARAMS.h"
70    #include "EESUPPORT.h"
71  #include "PARAMS.h"  #include "PARAMS.h"
72    
73  C Routine arguments  C Routine arguments
# Line 51  C Routine arguments Line 75  C Routine arguments
75        integer filePrec        integer filePrec
76        character*(2) arrType        character*(2) arrType
77        integer nNz        integer nNz
78        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nNz)        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
79        integer irecord        integer irecord
80        integer myThid        integer myThid
   
 #ifdef ALLOW_BROKEN_MDSIO_GL  
   
81  C Functions  C Functions
82        integer ILNBLNK        integer ILNBLNK
83        integer MDS_RECLEN        integer MDS_RECLEN
84  C Local variables  C Local variables
85        character*(80) dataFName        character*(MAX_LEN_FNAM) dataFName
86        integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL        integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
87        logical exst        logical exst
 C The following declaration isn't F77 and breaks under several compilers.  
 C To fix this, copies of the routines MDS_SEG4toRS, etc. need to be  
 C written to act on arrays shaped as "arr_gl" is above.  
 C          ...to be done by someone in ECCO...  
88        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
89        Real*4 r4seg(sNx)        Real*4 r4seg(sNx)
90        Real*8 r8seg(sNx)        Real*8 r8seg(sNx)
91        logical globalFile,fileIsOpen        logical globalFile,fileIsOpen
92        integer length_of_rec        integer length_of_rec
93        character*(max_len_mbuf) msgbuf        character*(max_len_mbuf) msgbuf
94    cph-usesingle(
95          integer ii,jj
96    c     integer iG_IO,jG_IO,npe
97          integer x_size,y_size
98          PARAMETER ( x_size = Nx )
99          PARAMETER ( y_size = Ny )
100          Real*4 xy_buffer_r4(x_size,y_size)
101          Real*8 xy_buffer_r8(x_size,y_size)
102          Real*8 global(Nx,Ny)
103    c     _RL    local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
104    cph-usesingle)
105    
106  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
107    
108  C Only do I/O if I am the master thread  C Only do I/O if I am the master thread
# Line 99  C Assume nothing Line 128  C Assume nothing
128  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
129        call MDSFINDUNIT( dUnit, mythid )        call MDSFINDUNIT( dUnit, mythid )
130    
131          if ( useSingleCPUIO ) then
132    
133    #ifdef ALLOW_USE_MPI
134            IF( mpiMyId .EQ. 0 ) THEN
135    #else
136            IF ( .TRUE. ) THEN
137    #endif /* ALLOW_USE_MPI */
138    
139  C Check first for global file with simple name (ie. fName)  C Check first for global file with simple name (ie. fName)
140        dataFName = fName           dataFName = fName
141        inquire( file=dataFname, exist=exst )           inquire( file=dataFname, exist=exst )
142        if (exst) then           if (exst) globalFile = .TRUE.
        write(msgbuf,'(a,a)')  
      &   ' MDSREADFIELD: opening global file: ',dataFName  
        call print_message( msgbuf, standardmessageunit,  
      &                     SQUEEZE_RIGHT , mythid)  
        stop " xx, adxx, weights and masks are not supposed to be global"  
       endif  
143    
144  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)
145        if (.NOT. globalFile) then           if (.NOT. globalFile) then
146         write(dataFname(1:80),'(2a)') fName(1:IL),'.data'            write(dataFname,'(2a)') fName(1:IL),'.data'
147              inquire( file=dataFname, exist=exst )
148              if (exst) globalFile = .TRUE.
149             endif
150    
151    C If global file is visible to process 0, then open it here.
152    C Otherwise stop program.
153             if ( globalFile) then
154              length_of_rec=MDS_RECLEN( filePrec, x_size*y_size, mythid )
155              open( dUnit, file=dataFName, status='old',
156         &         access='direct', recl=length_of_rec )
157             else
158              write(msgbuf,'(2a)')
159         &      ' MDSREADFIELD: filename: ',dataFName(1:IL)
160              call print_message( msgbuf, standardmessageunit,
161         &                        SQUEEZE_RIGHT , mythid)
162              call print_error( msgbuf, mythid )
163              write(msgbuf,'(a)')
164         &      ' MDSREADFIELD: File does not exist'
165              call print_message( msgbuf, standardmessageunit,
166         &                        SQUEEZE_RIGHT , mythid)
167              call print_error( msgbuf, mythid )
168              stop 'ABNORMAL END: S/R MDSREADFIELD'
169             endif
170    
171            ENDIF
172    
173    c-- useSingleCpuIO
174          else
175    C Only do I/O if I am the master thread
176    
177    C Check first for global file with simple name (ie. fName)
178           dataFName = fName
179         inquire( file=dataFname, exist=exst )         inquire( file=dataFname, exist=exst )
180         if (exst) then         if (exst) then
181          write(msgbuf,'(a,a)')          write(msgbuf,'(a,a)')
182       &    ' MDSREADFIELD_GL: opening global file: ',dataFName       &    ' MDSREADFIELD: opening global file: ',dataFName(1:IL)
183          call print_message( msgbuf, standardmessageunit,          call print_message( msgbuf, standardmessageunit,
184       &                      SQUEEZE_RIGHT , mythid)       &                      SQUEEZE_RIGHT , mythid)
         globalFile = .TRUE.  
        stop " xx, adxx, weights and masks are not supposed to be global"  
185         endif         endif
186    
187    C If negative check for global file with MDS name (ie. fName.data)
188           if (.NOT. globalFile) then
189            write(dataFname,'(2a)') fName(1:IL),'.data'
190            inquire( file=dataFname, exist=exst )
191            if (exst) then
192             write(msgbuf,'(a,a)')
193         &     ' MDSREADFIELD_GL: opening global file: ',dataFName(1:IL+5)
194             call print_message( msgbuf, standardmessageunit,
195         &                       SQUEEZE_RIGHT , mythid)
196             globalFile = .TRUE.
197            endif
198           endif
199    
200    c-- useSingleCpuIO
201          endif
202    
203          if ( .not. useSingleCpuIO ) then
204    cph      if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
205          if ( .not. ( globalFile ) ) then
206    
207    C If we are reading from a global file then we open it here
208          if (globalFile) then
209           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
210           open( dUnit, file=dataFName, status='old',
211         &      access='direct', recl=length_of_rec )
212           fileIsOpen=.TRUE.
213        endif        endif
214    
215  C Loop over all processors      C Loop over all processors    
216        do jp=1,nPy        do jp=1,nPy
217        do ip=1,nPx        do ip=1,nPx
# Line 133  C If we are reading from a tiled MDS fil Line 222  C If we are reading from a tiled MDS fil
222          if (.NOT. globalFile) then          if (.NOT. globalFile) then
223           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
224           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
225           write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')           write(dataFname,'(2a,i3.3,a,i3.3,a)')
226       &              fName(1:IL),'.',iG,'.',jG,'.data'       &              fName(1:IL),'.',iG,'.',jG,'.data'
227           inquire( file=dataFname, exist=exst )           inquire( file=dataFname, exist=exst )
228  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"
229  C (This is a place-holder for the active/passive mechanism  C (This is a place-holder for the active/passive mechanism
230           if (exst) then           if (exst) then
231            write(msgbuf,'(a,a)')            if ( debugLevel .GE. debLevA ) then
232       &      ' MDSREADFIELD_GL: opening file: ',dataFName             write(msgbuf,'(a,a)')
233            call print_message( msgbuf, standardmessageunit,       &      ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)
234               call print_message( msgbuf, standardmessageunit,
235       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
236              endif
237            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
238            open( dUnit, file=dataFName, status='old',            open( dUnit, file=dataFName, status='old',
239       &        access='direct', recl=length_of_rec )       &        access='direct', recl=length_of_rec )
# Line 150  C (This is a place-holder for the active Line 241  C (This is a place-holder for the active
241           else           else
242            fileIsOpen=.FALSE.            fileIsOpen=.FALSE.
243            write(msgbuf,'(a,a)')            write(msgbuf,'(a,a)')
244       &      ' MDSREADFIELD_GL: filename: ',dataFName       &      ' MDSREADFIELD_GL: filename: ',dataFName(1:IL+13)
245            call print_message( msgbuf, standardmessageunit,            call print_message( msgbuf, standardmessageunit,
246       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
247              call print_error( msgbuf, mythid )
248            write(msgbuf,'(a)')            write(msgbuf,'(a)')
249       &      ' MDSREADFIELD_GL: File does not exist'       &      ' MDSREADFIELD_GL: File does not exist'
250              call print_message( msgbuf, standardmessageunit,
251         &                        SQUEEZE_RIGHT , mythid)
252            call print_error( msgbuf, mythid )            call print_error( msgbuf, mythid )
253            stop 'ABNORMAL END: S/R MDSREADFIELD_GL'            stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
254           endif           endif
255          endif          endif
256    
257          if (fileIsOpen) then          if (fileIsOpen) then
258           do k=1,nNz           do k=1,Nr
259            do j=1,sNy            do j=1,sNy
260               if (globalFile) then
261                iG=bi+(ip-1)*nsx
262                jG=bj+(jp-1)*nsy
263                irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
264         &             + nSx*nPx*Ny*nNz*(irecord-1)
265               else
266              iG = 0              iG = 0
267              jG = 0              jG = 0
268              irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
269               endif
270             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
271              read(dUnit,rec=irec) r4seg              read(dUnit,rec=irec) r4seg
272  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
273              call MDS_BYTESWAPR4( sNx, r4seg )              call MDS_BYTESWAPR4( sNx, r4seg )
274  #endif  #endif
275              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
276               call MDS_SEG4toRS( j,bi,bj,k,nNz, r4seg, .TRUE., arr )               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
277              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
278               call MDS_SEG4toRL( j,bi,bj,k,nNz, r4seg, .TRUE., arr )               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
279              else              else
280               write(msgbuf,'(a)')               write(msgbuf,'(a)')
281       &         ' MDSREADFIELD_GL: illegal value for arrType'       &         ' MDSREADFIELD_GL: illegal value for arrType'
# Line 187  C (This is a place-holder for the active Line 288  C (This is a place-holder for the active
288              call MDS_BYTESWAPR8( sNx, r8seg )              call MDS_BYTESWAPR8( sNx, r8seg )
289  #endif  #endif
290              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
291               call MDS_SEG8toRS( j,bi,bj,k,nNz, r8seg, .TRUE., arr )               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
292              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
293               call MDS_SEG8toRL( j,bi,bj,k,nNz, r8seg, .TRUE., arr )               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
294              else              else
295               write(msgbuf,'(a)')               write(msgbuf,'(a)')
296       &         ' MDSREADFIELD_GL: illegal value for arrType'       &         ' MDSREADFIELD_GL: illegal value for arrType'
# Line 228  C If global file was opened then close i Line 329  C If global file was opened then close i
329         fileIsOpen = .FALSE.         fileIsOpen = .FALSE.
330        endif        endif
331    
332    c      end of if ( .not. ( globalFile ) ) then
333          endif
334    
335    c      else of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
336          else
337    
338           DO k=1,nNz
339    
340    #ifdef ALLOW_USE_MPI
341             IF( mpiMyId .EQ. 0 ) THEN
342    #else
343             IF ( .TRUE. ) THEN
344    #endif /* ALLOW_USE_MPI */
345              irec = k+nNz*(irecord-1)
346              if (filePrec .eq. precFloat32) then
347               read(dUnit,rec=irec) xy_buffer_r4
348    #ifdef _BYTESWAPIO
349               call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
350    #endif
351               DO J=1,Ny
352                DO I=1,Nx
353                 global(I,J) = xy_buffer_r4(I,J)
354                ENDDO
355               ENDDO
356              elseif (filePrec .eq. precFloat64) then
357               read(dUnit,rec=irec) xy_buffer_r8
358    #ifdef _BYTESWAPIO
359               call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
360    #endif
361               DO J=1,Ny
362                DO I=1,Nx
363                 global(I,J) = xy_buffer_r8(I,J)
364                ENDDO
365               ENDDO
366              else
367               write(msgbuf,'(a)')
368         &            ' MDSREADFIELD: illegal value for filePrec'
369               call print_error( msgbuf, mythid )
370               stop 'ABNORMAL END: S/R MDSREADFIELD'
371              endif
372             ENDIF
373            DO jp=1,nPy
374             DO ip=1,nPx
375              DO bj = myByLo(myThid), myByHi(myThid)
376               DO bi = myBxLo(myThid), myBxHi(myThid)
377                DO J=1,sNy
378                 JJ=((jp-1)*nSy+(bj-1))*sNy+J
379                 DO I=1,sNx
380                  II=((ip-1)*nSx+(bi-1))*sNx+I
381                  arr_gl(i,bi,ip,j,bj,jp,k) = global(II,JJ)
382                 ENDDO
383                ENDDO
384               ENDDO
385              ENDDO
386             ENDDO
387            ENDDO
388    
389           ENDDO
390    c      ENDDO k=1,nNz
391    
392            close( dUnit )
393    
394          endif
395    c      end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
396    
397        _END_MASTER( myThid )        _END_MASTER( myThid )
398    
399  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
# Line 236  C     ---------------------------------- Line 402  C     ----------------------------------
402  C=======================================================================  C=======================================================================
403    
404  C=======================================================================  C=======================================================================
405        SUBROUTINE MDSWRITEFIELD_GL(        SUBROUTINE MDSWRITEFIELD_3D_GL(
406       I   fName,       I   fName,
407       I   filePrec,       I   filePrec,
408       I   arrType,       I   arrType,
# Line 286  C          open(dUnit, ..., status='old' Line 452  C          open(dUnit, ..., status='old'
452  C Global variables / common blocks  C Global variables / common blocks
453  #include "SIZE.h"  #include "SIZE.h"
454  #include "EEPARAMS.h"  #include "EEPARAMS.h"
455    #include "EESUPPORT.h"
456  #include "PARAMS.h"  #include "PARAMS.h"
457    
458  C Routine arguments  C Routine arguments
# Line 295  C Routine arguments Line 462  C Routine arguments
462        integer nNz        integer nNz
463  cph(  cph(
464  cph      Real arr(*)  cph      Real arr(*)
465        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nNz)        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
466  cph)  cph)
467        integer irecord        integer irecord
468        integer myIter        integer myIter
# Line 304  C Functions Line 471  C Functions
471        integer ILNBLNK        integer ILNBLNK
472        integer MDS_RECLEN        integer MDS_RECLEN
473  C Local variables  C Local variables
474        character*(80) dataFName,metaFName        character*(MAX_LEN_FNAM) dataFName,metaFName
475        integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL        integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
476        Real*4 r4seg(sNx)        Real*4 r4seg(sNx)
477        Real*8 r8seg(sNx)        Real*8 r8seg(sNx)
478        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
# Line 313  C Local variables Line 480  C Local variables
480        integer length_of_rec        integer length_of_rec
481        logical fileIsOpen        logical fileIsOpen
482        character*(max_len_mbuf) msgbuf        character*(max_len_mbuf) msgbuf
483    cph-usesingle(
484    #ifdef ALLOW_USE_MPI
485          integer ii,jj
486          integer x_size,y_size,iG_IO,jG_IO,npe
487          PARAMETER ( x_size = Nx )
488          PARAMETER ( y_size = Ny )
489          Real*4 xy_buffer_r4(x_size,y_size)
490          Real*8 xy_buffer_r8(x_size,y_size)
491          Real*8 global(Nx,Ny)
492    #endif
493    cph-usesingle)
494    
495  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
496    
497  C Only do I/O if I am the master thread  C Only do I/O if I am the master thread
# Line 337  C Assume nothing Line 516  C Assume nothing
516  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
517        call MDSFINDUNIT( dUnit, mythid )        call MDSFINDUNIT( dUnit, mythid )
518    
519    cph-usesingle(
520    #ifdef ALLOW_USE_MPI
521          _END_MASTER( myThid )
522    C If option globalFile is desired but does not work or if
523    C globalFile is too slow, then try using single-CPU I/O.
524          if (useSingleCpuIO) then
525    
526    C Master thread of process 0, only, opens a global file
527           _BEGIN_MASTER( myThid )
528            IF( mpiMyId .EQ. 0 ) THEN
529             write(dataFname,'(2a)') fName(1:IL),'.data'
530             length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
531             if (irecord .EQ. 1) then
532              open( dUnit, file=dataFName, status=_NEW_STATUS,
533         &        access='direct', recl=length_of_rec )
534             else
535              open( dUnit, file=dataFName, status=_OLD_STATUS,
536         &        access='direct', recl=length_of_rec )
537             endif
538            ENDIF
539           _END_MASTER( myThid )
540    
541    C Gather array and write it to file, one vertical level at a time
542           DO k=1,nNz
543    C Loop over all processors    
544            do jp=1,nPy
545            do ip=1,nPx
546            DO bj = myByLo(myThid), myByHi(myThid)
547             DO bi = myBxLo(myThid), myBxHi(myThid)
548              DO J=1,sNy
549               JJ=((jp-1)*nSy+(bj-1))*sNy+J
550               DO I=1,sNx
551                II=((ip-1)*nSx+(bi-1))*sNx+I
552                global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
553               ENDDO
554              ENDDO
555             ENDDO
556            ENDDO
557            enddo
558            enddo
559            _BEGIN_MASTER( myThid )
560             IF( mpiMyId .EQ. 0 ) THEN
561              irec=k+nNz*(irecord-1)
562              if (filePrec .eq. precFloat32) then
563               DO J=1,Ny
564                DO I=1,Nx
565                 xy_buffer_r4(I,J) = global(I,J)
566                ENDDO
567               ENDDO
568    #ifdef _BYTESWAPIO
569               call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
570    #endif
571               write(dUnit,rec=irec) xy_buffer_r4
572              elseif (filePrec .eq. precFloat64) then
573               DO J=1,Ny
574                DO I=1,Nx
575                 xy_buffer_r8(I,J) = global(I,J)
576                ENDDO
577               ENDDO
578    #ifdef _BYTESWAPIO
579               call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
580    #endif
581               write(dUnit,rec=irec) xy_buffer_r8
582              else
583               write(msgbuf,'(a)')
584         &       ' MDSWRITEFIELD: illegal value for filePrec'
585               call print_error( msgbuf, mythid )
586               stop 'ABNORMAL END: S/R MDSWRITEFIELD'
587              endif
588             ENDIF
589            _END_MASTER( myThid )
590           ENDDO
591    
592    C Close data-file and create meta-file
593           _BEGIN_MASTER( myThid )
594            IF( mpiMyId .EQ. 0 ) THEN
595             close( dUnit )
596             write(metaFName,'(2a)') fName(1:IL),'.meta'
597             dimList(1,1)=Nx
598             dimList(2,1)=1
599             dimList(3,1)=Nx
600             dimList(1,2)=Ny
601             dimList(2,2)=1
602             dimList(3,2)=Ny
603             dimList(1,3)=nNz
604             dimList(2,3)=1
605             dimList(3,3)=nNz
606             ndims=3
607             if (nNz .EQ. 1) ndims=2
608             call MDSWRITEMETA( metaFName, dataFName,
609         &     filePrec, ndims, dimList, irecord, myIter, mythid )
610            ENDIF
611           _END_MASTER( myThid )
612    C To be safe, make other processes wait for I/O completion
613           _BARRIER
614    
615          elseif ( .NOT. useSingleCpuIO ) then
616          _BEGIN_MASTER( myThid )
617    #endif /* ALLOW_USE_MPI */
618    cph-usesingle)
619    
620  C Loop over all processors      C Loop over all processors    
621        do jp=1,nPy        do jp=1,nPy
# Line 347  C Loop over all tiles Line 626  C Loop over all tiles
626  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
627           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
628           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
629           write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')           write(dataFname,'(2a,i3.3,a,i3.3,a)')
630       &              fName(1:IL),'.',iG,'.',jG,'.data'       &              fName(1:IL),'.',iG,'.',jG,'.data'
631           if (irecord .EQ. 1) then           if (irecord .EQ. 1) then
632            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
# Line 361  C If we are writing to a tiled MDS file Line 640  C If we are writing to a tiled MDS file
640            fileIsOpen=.TRUE.            fileIsOpen=.TRUE.
641           endif           endif
642          if (fileIsOpen) then          if (fileIsOpen) then
643           do k=1,nNz           do k=1,Nr
644            do j=1,sNy            do j=1,sNy
645               do ii=1,sNx               do i=1,sNx
646                  arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)                  arr(i,j,k,bi,bj)=arr_gl(i,bi,ip,j,bj,jp,k)
647               enddo               enddo
648              iG = 0              iG = 0
649              jG = 0              jG = 0
650              irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
651             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
652              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
653               call MDS_SEG4toRS( j,bi,bj,k,nNz, r4seg, .FALSE., arr )               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
654              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
655               call MDS_SEG4toRL( j,bi,bj,k,nNz, r4seg, .FALSE., arr )               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
656              else              else
657               write(msgbuf,'(a)')               write(msgbuf,'(a)')
658       &         ' MDSWRITEFIELD_GL: illegal value for arrType'       &         ' MDSWRITEFIELD_GL: illegal value for arrType'
# Line 386  C If we are writing to a tiled MDS file Line 665  C If we are writing to a tiled MDS file
665              write(dUnit,rec=irec) r4seg              write(dUnit,rec=irec) r4seg
666             elseif (filePrec .eq. precFloat64) then             elseif (filePrec .eq. precFloat64) then
667              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
668               call MDS_SEG8toRS( j,bi,bj,k,nNz, r8seg, .FALSE., arr )               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
669              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
670               call MDS_SEG8toRL( j,bi,bj,k,nNz, r8seg, .FALSE., arr )               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
671              else              else
672               write(msgbuf,'(a)')               write(msgbuf,'(a)')
673       &         ' MDSWRITEFIELD_GL: illegal value for arrType'       &         ' MDSWRITEFIELD_GL: illegal value for arrType'
# Line 423  C If we were writing to a tiled MDS file Line 702  C If we were writing to a tiled MDS file
702  C Create meta-file for each tile if we are tiling  C Create meta-file for each tile if we are tiling
703           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
704           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
705           write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')           write(metaFname,'(2a,i3.3,a,i3.3,a)')
706       &              fName(1:IL),'.',iG,'.',jG,'.meta'       &              fName(1:IL),'.',iG,'.',jG,'.meta'
707           dimList(1,1)=Nx           dimList(1,1)=Nx
708           dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1           dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
# Line 435  C Create meta-file for each tile if we a Line 714  C Create meta-file for each tile if we a
714           dimList(2,3)=1           dimList(2,3)=1
715           dimList(3,3)=Nr           dimList(3,3)=Nr
716           ndims=3           ndims=3
717           if (nNz .EQ. 1) ndims=2           if (Nr .EQ. 1) ndims=2
718           call MDSWRITEMETA( metaFName, dataFName,           call MDSWRITEMETA( metaFName, dataFName,
719       &     filePrec, ndims, dimList, irecord, myIter, mythid )       &     filePrec, ndims, dimList, irecord, myIter, mythid )
720  C End of bi,bj loops  C End of bi,bj loops
# Line 445  C End of ip,jp loops Line 724  C End of ip,jp loops
724         enddo         enddo
725        enddo        enddo
726    
   
727        _END_MASTER( myThid )        _END_MASTER( myThid )
728    
729  #endif  cph-usesingle(
730    #ifdef ALLOW_USE_MPI
731    C endif useSingleCpuIO
732          endif
733    #endif /* ALLOW_USE_MPI */
734    cph-usesingle)
735    
736    C     ------------------------------------------------------------------
737          return
738          end
739    C=======================================================================
740    
741    C=======================================================================
742          SUBROUTINE MDSREADFIELD_2D_GL(
743         I   fName,
744         I   filePrec,
745         I   arrType,
746         I   nNz,
747         O   arr_gl,
748         I   irecord,
749         I   myThid )
750    C
751    C Arguments:
752    C
753    C fName         string  base name for file to read
754    C filePrec      integer number of bits per word in file (32 or 64)
755    C arrType       char(2) declaration of "arr": either "RS" or "RL"
756    C nNz           integer size of third dimension: normally either 1 or Nr
757    C arr           RS/RL   array to read into, arr(:,:,nNz,:,:)
758    C irecord       integer record number to read
759    C myThid        integer thread identifier
760    C
761    C MDSREADFIELD first checks to see if the file "fName" exists, then
762    C if the file "fName.data" exists and finally the tiled files of the
763    C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
764    C read because it is difficult to parse files in fortran.
765    C The precision of the file is decsribed by filePrec, set either
766    C to floatPrec32 or floatPrec64. The precision or declaration of
767    C the array argument must be consistently described by the char*(2)
768    C string arrType, either "RS" or "RL". nNz allows for both 2-D and
769    C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
770    C nNz=Nr implies a 3-D model field. irecord is the record number
771    C to be read and must be >= 1. The file data is stored in
772    C arr *but* the overlaps are *not* updated. ie. An exchange must
773    C be called. This is because the routine is sometimes called from
774    C within a MASTER_THID region.
775    C
776    C Created: 03/16/99 adcroft@mit.edu
777    
778          implicit none
779    C Global variables / common blocks
780    #include "SIZE.h"
781    #include "EEPARAMS.h"
782    #include "EESUPPORT.h"
783    #include "PARAMS.h"
784    
785    C Routine arguments
786          character*(*) fName
787          integer filePrec
788          character*(2) arrType
789          integer nNz, nLocz
790          parameter (nLocz = 1)
791          _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
792          integer irecord
793          integer myThid
794    C Functions
795          integer ILNBLNK
796          integer MDS_RECLEN
797    C Local variables
798          character*(MAX_LEN_FNAM) dataFName
799          integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
800          logical exst
801          _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
802          Real*4 r4seg(sNx)
803          Real*8 r8seg(sNx)
804          logical globalFile,fileIsOpen
805          integer length_of_rec
806          character*(max_len_mbuf) msgbuf
807    cph-usesingle(
808          integer ii,jj
809    c     integer iG_IO,jG_IO,npe
810          integer x_size,y_size
811          PARAMETER ( x_size = Nx )
812          PARAMETER ( y_size = Ny )
813          Real*4 xy_buffer_r4(x_size,y_size)
814          Real*8 xy_buffer_r8(x_size,y_size)
815          Real*8 global(Nx,Ny)
816    c     _RL    local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
817    cph-usesingle)
818    
819    C     ------------------------------------------------------------------
820    
821    C Only do I/O if I am the master thread
822          _BEGIN_MASTER( myThid )
823    
824    C Record number must be >= 1
825          if (irecord .LT. 1) then
826           write(msgbuf,'(a,i9.8)')
827         &   ' MDSREADFIELD_GL: argument irecord = ',irecord
828           call print_message( msgbuf, standardmessageunit,
829         &                     SQUEEZE_RIGHT , mythid)
830           write(msgbuf,'(a)')
831         &   ' MDSREADFIELD_GL: Invalid value for irecord'
832           call print_error( msgbuf, mythid )
833           stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
834          endif
835    
836    C Assume nothing
837          globalFile = .FALSE.
838          fileIsOpen = .FALSE.
839          IL=ILNBLNK( fName )
840    
841    C Assign a free unit number as the I/O channel for this routine
842          call MDSFINDUNIT( dUnit, mythid )
843    
844          if ( useSingleCPUIO ) then
845    
846    C master thread of process 0, only, opens a global file
847    #ifdef ALLOW_USE_MPI
848            IF( mpiMyId .EQ. 0 ) THEN
849    #else
850            IF ( .TRUE. ) THEN
851    #endif /* ALLOW_USE_MPI */
852    
853    C Check first for global file with simple name (ie. fName)
854             dataFName = fName
855             inquire( file=dataFname, exist=exst )
856             if (exst) globalFile = .TRUE.
857    
858    C If negative check for global file with MDS name (ie. fName.data)
859             if (.NOT. globalFile) then
860              write(dataFname,'(2a)') fName(1:IL),'.data'
861              inquire( file=dataFname, exist=exst )
862              if (exst) globalFile = .TRUE.
863             endif
864    
865    C If global file is visible to process 0, then open it here.
866    C Otherwise stop program.
867             if ( globalFile) then
868              length_of_rec=MDS_RECLEN( filePrec, x_size*y_size, mythid )
869              open( dUnit, file=dataFName, status='old',
870         &         access='direct', recl=length_of_rec )
871             else
872              write(msgbuf,'(2a)')
873         &      ' MDSREADFIELD: filename: ',dataFName(1:IL)
874              call print_message( msgbuf, standardmessageunit,
875         &                        SQUEEZE_RIGHT , mythid)
876              call print_error( msgbuf, mythid )
877              write(msgbuf,'(a)')
878         &      ' MDSREADFIELD: File does not exist'
879              call print_message( msgbuf, standardmessageunit,
880         &                        SQUEEZE_RIGHT , mythid)
881              call print_error( msgbuf, mythid )
882              stop 'ABNORMAL END: S/R MDSREADFIELD'
883             endif
884    
885            ENDIF
886    
887    c-- useSingleCpuIO
888          else
889    
890    C Check first for global file with simple name (ie. fName)
891           dataFName = fName
892           inquire( file=dataFname, exist=exst )
893           if (exst) then
894            write(msgbuf,'(a,a)')
895         &    ' MDSREADFIELD: opening global file: ',dataFName(1:IL)
896            call print_message( msgbuf, standardmessageunit,
897         &                      SQUEEZE_RIGHT , mythid)
898           endif
899    
900    C If negative check for global file with MDS name (ie. fName.data)
901           if (.NOT. globalFile) then
902            write(dataFname,'(2a)') fName(1:IL),'.data'
903            inquire( file=dataFname, exist=exst )
904            if (exst) then
905             write(msgbuf,'(a,a)')
906         &     ' MDSREADFIELD_GL: opening global file: ',dataFName(1:IL+5)
907             call print_message( msgbuf, standardmessageunit,
908         &                       SQUEEZE_RIGHT , mythid)
909             globalFile = .TRUE.
910            endif
911           endif
912    
913    c-- useSingleCpuIO
914          endif
915    
916          if ( .not. useSingleCpuIO ) then
917    cph      if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
918          if ( .not. ( globalFile ) ) then
919    
920    C If we are reading from a global file then we open it here
921          if (globalFile) then
922           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
923           open( dUnit, file=dataFName, status='old',
924         &      access='direct', recl=length_of_rec )
925           fileIsOpen=.TRUE.
926          endif
927    
928    C Loop over all processors    
929          do jp=1,nPy
930          do ip=1,nPx
931    C Loop over all tiles
932          do bj=1,nSy
933          do bi=1,nSx
934    C If we are reading from a tiled MDS file then we open each one here
935            if (.NOT. globalFile) then
936             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
937             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
938             write(dataFname,'(2a,i3.3,a,i3.3,a)')
939         &              fName(1:IL),'.',iG,'.',jG,'.data'
940             inquire( file=dataFname, exist=exst )
941    C Of course, we only open the file if the tile is "active"
942    C (This is a place-holder for the active/passive mechanism
943             if (exst) then
944              if ( debugLevel .GE. debLevA ) then
945               write(msgbuf,'(a,a)')
946         &      ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)
947               call print_message( msgbuf, standardmessageunit,
948         &                        SQUEEZE_RIGHT , mythid)
949              endif
950              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
951              open( dUnit, file=dataFName, status='old',
952         &        access='direct', recl=length_of_rec )
953              fileIsOpen=.TRUE.
954             else
955              fileIsOpen=.FALSE.
956              write(msgbuf,'(a,a)')
957         &      ' MDSREADFIELD_GL: filename: ',dataFName(1:IL+13)
958              call print_message( msgbuf, standardmessageunit,
959         &                        SQUEEZE_RIGHT , mythid)
960              call print_error( msgbuf, mythid )
961              write(msgbuf,'(a)')
962         &      ' MDSREADFIELD_GL: File does not exist'
963              call print_message( msgbuf, standardmessageunit,
964         &                        SQUEEZE_RIGHT , mythid)
965              call print_error( msgbuf, mythid )
966              stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
967             endif
968            endif
969    
970            if (fileIsOpen) then
971             do k=1,nLocz
972              do j=1,sNy
973               if (globalFile) then
974                iG=bi+(ip-1)*nsx
975                jG=bj+(jp-1)*nsy
976                irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
977         &             + nSx*nPx*Ny*nLocz*(irecord-1)
978               else
979                iG = 0
980                jG = 0
981                irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
982               endif
983               if (filePrec .eq. precFloat32) then
984                read(dUnit,rec=irec) r4seg
985    #ifdef _BYTESWAPIO
986                call MDS_BYTESWAPR4( sNx, r4seg )
987    #endif
988                if (arrType .eq. 'RS') then
989                 call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
990                elseif (arrType .eq. 'RL') then
991                 call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
992                else
993                 write(msgbuf,'(a)')
994         &         ' MDSREADFIELD_GL: illegal value for arrType'
995                 call print_error( msgbuf, mythid )
996                 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
997                endif
998               elseif (filePrec .eq. precFloat64) then
999                read(dUnit,rec=irec) r8seg
1000    #ifdef _BYTESWAPIO
1001                call MDS_BYTESWAPR8( sNx, r8seg )
1002    #endif
1003                if (arrType .eq. 'RS') then
1004                 call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
1005                elseif (arrType .eq. 'RL') then
1006                 call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
1007                else
1008                 write(msgbuf,'(a)')
1009         &         ' MDSREADFIELD_GL: illegal value for arrType'
1010                 call print_error( msgbuf, mythid )
1011                 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
1012                endif
1013               else
1014                write(msgbuf,'(a)')
1015         &        ' MDSREADFIELD_GL: illegal value for filePrec'
1016                call print_error( msgbuf, mythid )
1017                stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
1018               endif
1019           do ii=1,sNx
1020            arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
1021           enddo
1022    
1023    C End of j loop
1024              enddo
1025    C End of k loop
1026             enddo
1027             if (.NOT. globalFile) then
1028              close( dUnit )
1029              fileIsOpen = .FALSE.
1030             endif
1031            endif
1032    C End of bi,bj loops
1033           enddo
1034          enddo
1035    C End of ip,jp loops
1036           enddo
1037          enddo
1038    
1039    C If global file was opened then close it
1040          if (fileIsOpen .AND. globalFile) then
1041           close( dUnit )
1042           fileIsOpen = .FALSE.
1043          endif
1044    
1045    c      end of if ( .not. ( globalFile ) ) then
1046          endif
1047    
1048    c      else of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
1049          else
1050    
1051           DO k=1,nLocz
1052    
1053    #ifdef ALLOW_USE_MPI
1054             IF( mpiMyId .EQ. 0 ) THEN
1055    #else
1056             IF ( .TRUE. ) THEN
1057    #endif /* ALLOW_USE_MPI */
1058              irec = k+nNz*(irecord-1)
1059              if (filePrec .eq. precFloat32) then
1060               read(dUnit,rec=irec) xy_buffer_r4
1061    #ifdef _BYTESWAPIO
1062               call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
1063    #endif
1064               DO J=1,Ny
1065                DO I=1,Nx
1066                 global(I,J) = xy_buffer_r4(I,J)
1067                ENDDO
1068               ENDDO
1069              elseif (filePrec .eq. precFloat64) then
1070               read(dUnit,rec=irec) xy_buffer_r8
1071    #ifdef _BYTESWAPIO
1072               call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
1073    #endif
1074               DO J=1,Ny
1075                DO I=1,Nx
1076                 global(I,J) = xy_buffer_r8(I,J)
1077                ENDDO
1078               ENDDO
1079              else
1080               write(msgbuf,'(a)')
1081         &            ' MDSREADFIELD: illegal value for filePrec'
1082               call print_error( msgbuf, mythid )
1083               stop 'ABNORMAL END: S/R MDSREADFIELD'
1084              endif
1085             ENDIF
1086            DO jp=1,nPy
1087             DO ip=1,nPx
1088              DO bj = myByLo(myThid), myByHi(myThid)
1089               DO bi = myBxLo(myThid), myBxHi(myThid)
1090                DO J=1,sNy
1091                 JJ=((jp-1)*nSy+(bj-1))*sNy+J
1092                 DO I=1,sNx
1093                  II=((ip-1)*nSx+(bi-1))*sNx+I
1094                  arr_gl(i,bi,ip,j,bj,jp,k) = global(II,JJ)
1095                 ENDDO
1096                ENDDO
1097               ENDDO
1098              ENDDO
1099             ENDDO
1100            ENDDO
1101    
1102           ENDDO
1103    c      ENDDO k=1,nNz
1104    
1105            close( dUnit )
1106    
1107          endif
1108    c      end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
1109    
1110          _END_MASTER( myThid )
1111    
1112    C     ------------------------------------------------------------------
1113          return
1114          end
1115    C=======================================================================
1116    
1117    C=======================================================================
1118          SUBROUTINE MDSWRITEFIELD_2D_GL(
1119         I   fName,
1120         I   filePrec,
1121         I   arrType,
1122         I   nNz,
1123         I   arr_gl,
1124         I   irecord,
1125         I   myIter,
1126         I   myThid )
1127    C
1128    C Arguments:
1129    C
1130    C fName         string  base name for file to written
1131    C filePrec      integer number of bits per word in file (32 or 64)
1132    C arrType       char(2) declaration of "arr": either "RS" or "RL"
1133    C nNz           integer size of third dimension: normally either 1 or Nr
1134    C arr           RS/RL   array to write, arr(:,:,nNz,:,:)
1135    C irecord       integer record number to read
1136    C myIter        integer time step number
1137    C myThid        integer thread identifier
1138    C
1139    C MDSWRITEFIELD creates either a file of the form "fName.data" and
1140    C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
1141    C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
1142    C "fName.xxx.yyy.meta". A meta-file is always created.
1143    C Currently, the meta-files are not read because it is difficult
1144    C to parse files in fortran. We should read meta information before
1145    C adding records to an existing multi-record file.
1146    C The precision of the file is decsribed by filePrec, set either
1147    C to floatPrec32 or floatPrec64. The precision or declaration of
1148    C the array argument must be consistently described by the char*(2)
1149    C string arrType, either "RS" or "RL". nNz allows for both 2-D and
1150    C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
1151    C nNz=Nr implies a 3-D model field. irecord is the record number
1152    C to be read and must be >= 1. NOTE: It is currently assumed that
1153    C the highest record number in the file was the last record written.
1154    C Nor is there a consistency check between the routine arguments and file.
1155    C ie. if your write record 2 after record 4 the meta information
1156    C will record the number of records to be 2. This, again, is because
1157    C we have read the meta information. To be fixed.
1158    C
1159    C Created: 03/16/99 adcroft@mit.edu
1160    C
1161    C Changed: 05/31/00 heimbach@mit.edu
1162    C          open(dUnit, ..., status='old', ... -> status='unknown'
1163    
1164          implicit none
1165    C Global variables / common blocks
1166    #include "SIZE.h"
1167    #include "EEPARAMS.h"
1168    #include "EESUPPORT.h"
1169    #include "PARAMS.h"
1170    
1171    C Routine arguments
1172          character*(*) fName
1173          integer filePrec
1174          character*(2) arrType
1175          integer nNz, nLocz
1176          parameter (nLocz = 1)
1177    cph(
1178    cph      Real arr(*)
1179          _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
1180    cph)
1181          integer irecord
1182          integer myIter
1183          integer myThid
1184    C Functions
1185          integer ILNBLNK
1186          integer MDS_RECLEN
1187    C Local variables
1188          character*(MAX_LEN_FNAM) dataFName,metaFName
1189          integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
1190          Real*4 r4seg(sNx)
1191          Real*8 r8seg(sNx)
1192          _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
1193          integer dimList(3,3),ndims
1194          integer length_of_rec
1195          logical fileIsOpen
1196          character*(max_len_mbuf) msgbuf
1197    cph-usesingle(
1198    #ifdef ALLOW_USE_MPI
1199          integer ii,jj
1200          integer x_size,y_size,iG_IO,jG_IO,npe
1201          PARAMETER ( x_size = Nx )
1202          PARAMETER ( y_size = Ny )
1203          Real*4 xy_buffer_r4(x_size,y_size)
1204          Real*8 xy_buffer_r8(x_size,y_size)
1205          Real*8 global(Nx,Ny)
1206    #endif
1207    cph-usesingle)
1208    
1209    C     ------------------------------------------------------------------
1210    
1211    C Only do I/O if I am the master thread
1212          _BEGIN_MASTER( myThid )
1213    
1214    C Record number must be >= 1
1215          if (irecord .LT. 1) then
1216           write(msgbuf,'(a,i9.8)')
1217         &   ' MDSWRITEFIELD_GL: argument irecord = ',irecord
1218           call print_message( msgbuf, standardmessageunit,
1219         &                     SQUEEZE_RIGHT , mythid)
1220           write(msgbuf,'(a)')
1221         &   ' MDSWRITEFIELD_GL: invalid value for irecord'
1222           call print_error( msgbuf, mythid )
1223           stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1224          endif
1225    
1226    C Assume nothing
1227          fileIsOpen=.FALSE.
1228          IL=ILNBLNK( fName )
1229    
1230    C Assign a free unit number as the I/O channel for this routine
1231          call MDSFINDUNIT( dUnit, mythid )
1232    
1233    
1234    cph-usesingle(
1235    #ifdef ALLOW_USE_MPI
1236          _END_MASTER( myThid )
1237    C If option globalFile is desired but does not work or if
1238    C globalFile is too slow, then try using single-CPU I/O.
1239          if (useSingleCpuIO) then
1240    
1241    C Master thread of process 0, only, opens a global file
1242           _BEGIN_MASTER( myThid )
1243            IF( mpiMyId .EQ. 0 ) THEN
1244             write(dataFname,'(2a)') fName(1:IL),'.data'
1245             length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
1246             if (irecord .EQ. 1) then
1247              open( dUnit, file=dataFName, status=_NEW_STATUS,
1248         &        access='direct', recl=length_of_rec )
1249             else
1250              open( dUnit, file=dataFName, status=_OLD_STATUS,
1251         &        access='direct', recl=length_of_rec )
1252             endif
1253            ENDIF
1254           _END_MASTER( myThid )
1255    
1256    C Gather array and write it to file, one vertical level at a time
1257           DO k=1,nLocz
1258    C Loop over all processors    
1259            do jp=1,nPy
1260            do ip=1,nPx
1261            DO bj = myByLo(myThid), myByHi(myThid)
1262             DO bi = myBxLo(myThid), myBxHi(myThid)
1263              DO J=1,sNy
1264               JJ=((jp-1)*nSy+(bj-1))*sNy+J
1265               DO I=1,sNx
1266                II=((ip-1)*nSx+(bi-1))*sNx+I
1267                global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
1268               ENDDO
1269              ENDDO
1270             ENDDO
1271            ENDDO
1272            enddo
1273            enddo
1274            _BEGIN_MASTER( myThid )
1275             IF( mpiMyId .EQ. 0 ) THEN
1276              irec=k+nLocz*(irecord-1)
1277              if (filePrec .eq. precFloat32) then
1278               DO J=1,Ny
1279                DO I=1,Nx
1280                 xy_buffer_r4(I,J) = global(I,J)
1281                ENDDO
1282               ENDDO
1283    #ifdef _BYTESWAPIO
1284               call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
1285    #endif
1286               write(dUnit,rec=irec) xy_buffer_r4
1287              elseif (filePrec .eq. precFloat64) then
1288               DO J=1,Ny
1289                DO I=1,Nx
1290                 xy_buffer_r8(I,J) = global(I,J)
1291                ENDDO
1292               ENDDO
1293    #ifdef _BYTESWAPIO
1294               call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
1295    #endif
1296               write(dUnit,rec=irec) xy_buffer_r8
1297              else
1298               write(msgbuf,'(a)')
1299         &       ' MDSWRITEFIELD: illegal value for filePrec'
1300               call print_error( msgbuf, mythid )
1301               stop 'ABNORMAL END: S/R MDSWRITEFIELD'
1302              endif
1303             ENDIF
1304            _END_MASTER( myThid )
1305           ENDDO
1306    
1307    C Close data-file and create meta-file
1308           _BEGIN_MASTER( myThid )
1309            IF( mpiMyId .EQ. 0 ) THEN
1310             close( dUnit )
1311             write(metaFName,'(2a)') fName(1:IL),'.meta'
1312             dimList(1,1)=Nx
1313             dimList(2,1)=1
1314             dimList(3,1)=Nx
1315             dimList(1,2)=Ny
1316             dimList(2,2)=1
1317             dimList(3,2)=Ny
1318             dimList(1,3)=nLocz
1319             dimList(2,3)=1
1320             dimList(3,3)=nLocz
1321             ndims=3
1322             if (nLocz .EQ. 1) ndims=2
1323             call MDSWRITEMETA( metaFName, dataFName,
1324         &     filePrec, ndims, dimList, irecord, myIter, mythid )
1325            ENDIF
1326           _END_MASTER( myThid )
1327    C To be safe, make other processes wait for I/O completion
1328           _BARRIER
1329    
1330          elseif ( .NOT. useSingleCpuIO ) then
1331          _BEGIN_MASTER( myThid )
1332    #endif /* ALLOW_USE_MPI */
1333    cph-usesingle)
1334    
1335    C Loop over all processors    
1336          do jp=1,nPy
1337          do ip=1,nPx
1338    C Loop over all tiles
1339          do bj=1,nSy
1340           do bi=1,nSx
1341    C If we are writing to a tiled MDS file then we open each one here
1342             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1343             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1344             write(dataFname,'(2a,i3.3,a,i3.3,a)')
1345         &              fName(1:IL),'.',iG,'.',jG,'.data'
1346             if (irecord .EQ. 1) then
1347              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1348              open( dUnit, file=dataFName, status=_NEW_STATUS,
1349         &       access='direct', recl=length_of_rec )
1350              fileIsOpen=.TRUE.
1351             else
1352              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1353              open( dUnit, file=dataFName, status=_OLD_STATUS,
1354         &       access='direct', recl=length_of_rec )
1355              fileIsOpen=.TRUE.
1356             endif
1357            if (fileIsOpen) then
1358             do k=1,nLocz
1359              do j=1,sNy
1360                 do i=1,sNx
1361                    arr(i,j,k,bi,bj)=arr_gl(i,bi,ip,j,bj,jp,k)
1362                 enddo
1363                iG = 0
1364                jG = 0
1365                irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
1366               if (filePrec .eq. precFloat32) then
1367                if (arrType .eq. 'RS') then
1368                 call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1369                elseif (arrType .eq. 'RL') then
1370                 call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1371                else
1372                 write(msgbuf,'(a)')
1373         &         ' MDSWRITEFIELD_GL: illegal value for arrType'
1374                 call print_error( msgbuf, mythid )
1375                 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1376                endif
1377    #ifdef _BYTESWAPIO
1378                call MDS_BYTESWAPR4( sNx, r4seg )
1379    #endif
1380                write(dUnit,rec=irec) r4seg
1381               elseif (filePrec .eq. precFloat64) then
1382                if (arrType .eq. 'RS') then
1383                 call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1384                elseif (arrType .eq. 'RL') then
1385                 call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1386                else
1387                 write(msgbuf,'(a)')
1388         &         ' MDSWRITEFIELD_GL: illegal value for arrType'
1389                 call print_error( msgbuf, mythid )
1390                 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1391                endif
1392    #ifdef _BYTESWAPIO
1393                call MDS_BYTESWAPR8( sNx, r8seg )
1394    #endif
1395                write(dUnit,rec=irec) r8seg
1396               else
1397                write(msgbuf,'(a)')
1398         &        ' MDSWRITEFIELD_GL: illegal value for filePrec'
1399                call print_error( msgbuf, mythid )
1400                stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1401               endif
1402    C End of j loop
1403              enddo
1404    C End of k loop
1405             enddo
1406            else
1407             write(msgbuf,'(a)')
1408         &     ' MDSWRITEFIELD_GL: I should never get to this point'
1409             call print_error( msgbuf, mythid )
1410             stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1411            endif
1412    C If we were writing to a tiled MDS file then we close it here
1413            if (fileIsOpen) then
1414             close( dUnit )
1415             fileIsOpen = .FALSE.
1416            endif
1417    C Create meta-file for each tile if we are tiling
1418             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1419             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1420             write(metaFname,'(2a,i3.3,a,i3.3,a)')
1421         &              fName(1:IL),'.',iG,'.',jG,'.meta'
1422             dimList(1,1)=Nx
1423             dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
1424             dimList(3,1)=((ip-1)*nSx+bi)*sNx
1425             dimList(1,2)=Ny
1426             dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
1427             dimList(3,2)=((jp-1)*nSy+bj)*sNy
1428             dimList(1,3)=Nr
1429             dimList(2,3)=1
1430             dimList(3,3)=Nr
1431             ndims=3
1432             if (nLocz .EQ. 1) ndims=2
1433             call MDSWRITEMETA( metaFName, dataFName,
1434         &     filePrec, ndims, dimList, irecord, myIter, mythid )
1435    C End of bi,bj loops
1436           enddo
1437          enddo
1438    C End of ip,jp loops
1439           enddo
1440          enddo
1441    
1442          _END_MASTER( myThid )
1443    
1444    #ifdef ALLOW_USE_MPI
1445    C endif useSingleCpuIO
1446          endif
1447    #endif /* ALLOW_USE_MPI */
1448    
1449  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
1450        return        return
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.13
  ViewVC Help
Powered by ViewVC 1.1.22