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