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