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