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