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