/[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.2 by heimbach, Sun Mar 25 22:31:53 2001 UTC revision 1.21 by jmc, Sun Jan 13 22:43:53 2013 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2    C $Name$
3    
4  #include "CPP_OPTIONS.h"  #include "MDSIO_OPTIONS.h"
5    
6  C The five "public" routines supplied here are:  C--  File mdsio_gl.F: Routines to handle mid-level I/O interface.
7  C  C--   Contents
8  C MDSREADFIELD   - read model field from direct access global or tiled MDS file  C--   o MDSREADFIELD_3D_GL
9  C MDSWRITEFIELD  - write model field to direct access global or tiled MDS file  C--   o MDSWRITEFIELD_3D_GL
10  C MDSFINDUNIT    - returns an available (unused) I/O channel  C--   o MDSREADFIELD_2D_GL
11  C MDSREADVECTOR  - read vector from direct access global or tiled MDS file  C--   o MDSWRITEFIELD_2D_GL
 C MDSWRITEVECTOR - write vector to direct access global or tiled MDS file  
 C  
 C all other routines are "private" to these utilities and ought  
 C not be accessed directly from the main code.  
 C  
 C Created:  03/16/99 adcroft@mit.edu  
 C Modified: 03/23/99 adcroft@mit.edu  
 C           To work with multiple records  
 C Modified: 03/29/99 eckert@mit.edu  
 C           Added arbitrary vector capability  
 C Modified: 07/27/99 eckert@mit.edu  
 C           Customized for state estimation (--> active_file_control.F)  
 C           this relates only to *mdsreadvector* and *mdswritevector*  
 C Modified: 07/28/99 eckert@mit.edu  
 C           inserted calls to *print_message* and *print_error*  
 C  
 C To be modified to work with MITgcmuv message routines.  
12    
13  #undef  SAFE_IO  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
   
 #ifdef SAFE_IO  
 #define _NEW_STATUS 'new'  
 #else  
 #define _NEW_STATUS 'unknown'  
 #endif  
   
 #ifdef ALLOW_AUTODIFF_TAMC  
 #define _OLD_STATUS 'unknown'  
 #else  
 #define _OLD_STATUS 'old'  
 #endif  
14    
 C=======================================================================  
15        SUBROUTINE MDSREADFIELD_3D_GL(        SUBROUTINE MDSREADFIELD_3D_GL(
16       I   fName,       I   fName,
17       I   filePrec,       I   filePrec,
# Line 52  C======================================= Line 23  C=======================================
23  C  C
24  C Arguments:  C Arguments:
25  C  C
26  C fName         string  base name for file to read  C fName     (string)  :: base name for file to read
27  C filePrec      integer number of bits per word in file (32 or 64)  C filePrec  (integer) :: number of bits per word in file (32 or 64)
28  C arrType       char(2) declaration of "arr": either "RS" or "RL"  C arrType   (char(2)) :: type of array "arr": either "RS" or "RL"
29  C nNz           integer size of third dimension: normally either 1 or Nr  C nNz       (integer) :: size of third dimension: normally either 1 or Nr
30  C arr           RS/RL   array to read into, arr(:,:,nNz,:,:)  C arr        (RS/RL)  :: array to read into, arr(:,:,nNz,:,:)
31  C irecord       integer record number to read  C irecord   (integer) :: record number to read
32  C myThid        integer thread identifier  C myThid    (integer) :: thread identifier
33  C  C
34  C MDSREADFIELD first checks to see if the file "fName" exists, then  C MDSREADFIELD first checks to see if the file "fName" exists, then
35  C if the file "fName.data" exists and finally the tiled files of the  C if the file "fName.data" exists and finally the tiled files of the
# Line 91  C Routine arguments Line 62  C Routine arguments
62        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
63        integer irecord        integer irecord
64        integer myThid        integer myThid
65    
66    #ifdef ALLOW_CTRL
67    
68  C Functions  C Functions
69        integer ILNBLNK        integer ILNBLNK
70        integer MDS_RECLEN        integer MDS_RECLEN
71  C Local variables  C Local variables
72        character*(80) dataFName        character*(MAX_LEN_FNAM) dataFName
73        integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL        integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
74        logical exst        logical exst
75        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
76        Real*4 r4seg(sNx)        Real*4 r4seg(sNx)
# Line 104  C Local variables Line 78  C Local variables
78        logical globalFile,fileIsOpen        logical globalFile,fileIsOpen
79        integer length_of_rec        integer length_of_rec
80        character*(max_len_mbuf) msgbuf        character*(max_len_mbuf) msgbuf
81    cph-usesingle(
82          integer ii,jj
83    c     integer iG_IO,jG_IO,npe
84          integer x_size,y_size
85          PARAMETER ( x_size = Nx )
86          PARAMETER ( y_size = Ny )
87          Real*4 xy_buffer_r4(x_size,y_size)
88          Real*8 xy_buffer_r8(x_size,y_size)
89          Real*8 global(Nx,Ny)
90    c     _RL    local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
91    cph-usesingle)
92    CMM(
93          integer pIL
94    CMM)
95    
96  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
97    
98  C Only do I/O if I am the master thread  C Only do I/O if I am the master thread
99        _BEGIN_MASTER( myThid )        _BEGIN_MASTER( myThid )
100    
101    #ifndef REAL4_IS_SLOW
102          if (arrType .eq. 'RS') then
103           write(msgbuf,'(a)')
104         &   ' MDSREADFIELD_GL is wrong for arrType="RS" (=real*4)'
105           call print_error( msgbuf, mythid )
106           stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
107          endif
108    #endif
109    
110  C Record number must be >= 1  C Record number must be >= 1
111        if (irecord .LT. 1) then        if (irecord .LT. 1) then
112         write(msgbuf,'(a,i9.8)')         write(msgbuf,'(a,i9.8)')
# Line 125  C Assume nothing Line 123  C Assume nothing
123        globalFile = .FALSE.        globalFile = .FALSE.
124        fileIsOpen = .FALSE.        fileIsOpen = .FALSE.
125        IL=ILNBLNK( fName )        IL=ILNBLNK( fName )
126    CMM(
127          pIL = ILNBLNK( mdsioLocalDir )
128    CMM)
129    CMM(
130    C Assign special directory
131          if ( pIL.NE.0 ) then
132           write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
133          endif
134    CMM)
135    
136  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
137        call MDSFINDUNIT( dUnit, mythid )        call MDSFINDUNIT( dUnit, mythid )
138    
139          if ( useSingleCPUIO ) then
140    
141    #ifdef ALLOW_USE_MPI
142            IF( myProcId .EQ. 0 ) THEN
143    #else
144            IF ( .TRUE. ) THEN
145    #endif /* ALLOW_USE_MPI */
146    
147  C Check first for global file with simple name (ie. fName)  C Check first for global file with simple name (ie. fName)
148        dataFName = fName           dataFName = fName
149        inquire( file=dataFname, exist=exst )           inquire( file=dataFname, exist=exst )
150        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  
151    
152  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)
153        if (.NOT. globalFile) then           if (.NOT. globalFile) then
154         write(dataFname(1:80),'(2a)') fName(1:IL),'.data'            write(dataFname,'(2a)') fName(1:IL),'.data'
155              inquire( file=dataFname, exist=exst )
156              if (exst) globalFile = .TRUE.
157             endif
158    
159    C If global file is visible to process 0, then open it here.
160    C Otherwise stop program.
161             if ( globalFile) then
162              length_of_rec=MDS_RECLEN( filePrec, x_size*y_size, mythid )
163              open( dUnit, file=dataFName, status='old',
164         &         access='direct', recl=length_of_rec )
165             else
166              write(msgbuf,'(2a)')
167         &      ' MDSREADFIELD: filename: ',dataFName(1:IL)
168              call print_message( msgbuf, standardmessageunit,
169         &                        SQUEEZE_RIGHT , mythid)
170              call print_error( msgbuf, mythid )
171              write(msgbuf,'(a)')
172         &      ' MDSREADFIELD: File does not exist'
173              call print_message( msgbuf, standardmessageunit,
174         &                        SQUEEZE_RIGHT , mythid)
175              call print_error( msgbuf, mythid )
176              stop 'ABNORMAL END: S/R MDSREADFIELD'
177             endif
178    
179            ENDIF
180    
181    c-- useSingleCpuIO
182          else
183    C Only do I/O if I am the master thread
184    
185    C Check first for global file with simple name (ie. fName)
186           dataFName = fName
187         inquire( file=dataFname, exist=exst )         inquire( file=dataFname, exist=exst )
188         if (exst) then         if (exst) then
189          write(msgbuf,'(a,a)')          write(msgbuf,'(a,a)')
190       &    ' MDSREADFIELD_GL: opening global file: ',dataFName       &    ' MDSREADFIELD: opening global file: ',dataFName(1:IL)
191          call print_message( msgbuf, standardmessageunit,          call print_message( msgbuf, standardmessageunit,
192       &                      SQUEEZE_RIGHT , mythid)       &                      SQUEEZE_RIGHT , mythid)
         globalFile = .TRUE.  
        stop " xx, adxx, weights and masks are not supposed to be global"  
193         endif         endif
194    
195    C If negative check for global file with MDS name (ie. fName.data)
196           if (.NOT. globalFile) then
197            write(dataFname,'(2a)') fName(1:IL),'.data'
198            inquire( file=dataFname, exist=exst )
199            if (exst) then
200             write(msgbuf,'(a,a)')
201         &     ' MDSREADFIELD_GL: opening global file: ',dataFName(1:IL+5)
202             call print_message( msgbuf, standardmessageunit,
203         &                       SQUEEZE_RIGHT , mythid)
204             globalFile = .TRUE.
205            endif
206           endif
207    
208    c-- useSingleCpuIO
209        endif        endif
210  C Loop over all processors      
211          if ( .not. useSingleCpuIO ) then
212    cph      if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
213          if ( .not. ( globalFile ) ) then
214    
215    C If we are reading from a global file then we open it here
216          if (globalFile) then
217           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
218           open( dUnit, file=dataFName, status='old',
219         &      access='direct', recl=length_of_rec )
220           fileIsOpen=.TRUE.
221          endif
222    
223    C Loop over all processors
224        do jp=1,nPy        do jp=1,nPy
225        do ip=1,nPx        do ip=1,nPx
226  C Loop over all tiles  C Loop over all tiles
# Line 163  C If we are reading from a tiled MDS fil Line 230  C If we are reading from a tiled MDS fil
230          if (.NOT. globalFile) then          if (.NOT. globalFile) then
231           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
232           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
233           write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')           write(dataFname,'(2a,i3.3,a,i3.3,a)')
234       &              fName(1:IL),'.',iG,'.',jG,'.data'       &              fName(1:IL),'.',iG,'.',jG,'.data'
235           inquire( file=dataFname, exist=exst )           inquire( file=dataFname, exist=exst )
236  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"
237  C (This is a place-holder for the active/passive mechanism  C (This is a place-holder for the active/passive mechanism
238           if (exst) then           if (exst) then
239            write(msgbuf,'(a,a)')            if ( debugLevel .GE. debLevB ) then
240       &      ' MDSREADFIELD_GL: opening file: ',dataFName             write(msgbuf,'(a,a)')
241            call print_message( msgbuf, standardmessageunit,       &      ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)
242               call print_message( msgbuf, standardmessageunit,
243       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
244              endif
245            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
246            open( dUnit, file=dataFName, status='old',            open( dUnit, file=dataFName, status='old',
247       &        access='direct', recl=length_of_rec )       &        access='direct', recl=length_of_rec )
# Line 180  C (This is a place-holder for the active Line 249  C (This is a place-holder for the active
249           else           else
250            fileIsOpen=.FALSE.            fileIsOpen=.FALSE.
251            write(msgbuf,'(a,a)')            write(msgbuf,'(a,a)')
252       &      ' MDSREADFIELD_GL: filename: ',dataFName       &      ' MDSREADFIELD_GL: filename: ',dataFName(1:IL+13)
253            call print_message( msgbuf, standardmessageunit,            call print_message( msgbuf, standardmessageunit,
254       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
255              call print_error( msgbuf, mythid )
256            write(msgbuf,'(a)')            write(msgbuf,'(a)')
257       &      ' MDSREADFIELD_GL: File does not exist'       &      ' MDSREADFIELD_GL: File does not exist'
258              call print_message( msgbuf, standardmessageunit,
259         &                        SQUEEZE_RIGHT , mythid)
260            call print_error( msgbuf, mythid )            call print_error( msgbuf, mythid )
261            stop 'ABNORMAL END: S/R MDSREADFIELD_GL'            stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
262           endif           endif
# Line 193  C (This is a place-holder for the active Line 265  C (This is a place-holder for the active
265          if (fileIsOpen) then          if (fileIsOpen) then
266           do k=1,Nr           do k=1,Nr
267            do j=1,sNy            do j=1,sNy
268               if (globalFile) then
269                iG=bi+(ip-1)*nsx
270                jG=bj+(jp-1)*nsy
271                irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
272         &             + nSx*nPx*Ny*nNz*(irecord-1)
273               else
274              iG = 0              iG = 0
275              jG = 0              jG = 0
276              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
277               endif
278             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
279              read(dUnit,rec=irec) r4seg              read(dUnit,rec=irec) r4seg
280  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
281              call MDS_BYTESWAPR4( sNx, r4seg )              call MDS_BYTESWAPR4( sNx, r4seg )
282  #endif  #endif
283              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
284    #ifdef REAL4_IS_SLOW
285               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .TRUE., arr )               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
286    #endif
287              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
288               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .TRUE., arr )               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
289              else              else
# Line 217  C (This is a place-holder for the active Line 298  C (This is a place-holder for the active
298              call MDS_BYTESWAPR8( sNx, r8seg )              call MDS_BYTESWAPR8( sNx, r8seg )
299  #endif  #endif
300              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
301    #ifdef REAL4_IS_SLOW
302               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .TRUE., arr )               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
303    #endif
304              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
305               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .TRUE., arr )               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
306              else              else
# Line 258  C If global file was opened then close i Line 341  C If global file was opened then close i
341         fileIsOpen = .FALSE.         fileIsOpen = .FALSE.
342        endif        endif
343    
344    c      end of if ( .not. ( globalFile ) ) then
345          endif
346    
347    c      else of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
348          else
349    
350           DO k=1,nNz
351    
352    #ifdef ALLOW_USE_MPI
353             IF( myProcId .EQ. 0 ) THEN
354    #else
355             IF ( .TRUE. ) THEN
356    #endif /* ALLOW_USE_MPI */
357              irec = k+nNz*(irecord-1)
358              if (filePrec .eq. precFloat32) then
359               read(dUnit,rec=irec) xy_buffer_r4
360    #ifdef _BYTESWAPIO
361               call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
362    #endif
363               DO J=1,Ny
364                DO I=1,Nx
365                 global(I,J) = xy_buffer_r4(I,J)
366                ENDDO
367               ENDDO
368              elseif (filePrec .eq. precFloat64) then
369               read(dUnit,rec=irec) xy_buffer_r8
370    #ifdef _BYTESWAPIO
371               call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
372    #endif
373               DO J=1,Ny
374                DO I=1,Nx
375                 global(I,J) = xy_buffer_r8(I,J)
376                ENDDO
377               ENDDO
378              else
379               write(msgbuf,'(a)')
380         &            ' MDSREADFIELD: illegal value for filePrec'
381               call print_error( msgbuf, mythid )
382               stop 'ABNORMAL END: S/R MDSREADFIELD'
383              endif
384             ENDIF
385            DO jp=1,nPy
386             DO ip=1,nPx
387              DO bj = myByLo(myThid), myByHi(myThid)
388               DO bi = myBxLo(myThid), myBxHi(myThid)
389                DO J=1,sNy
390                 JJ=((jp-1)*nSy+(bj-1))*sNy+J
391                 DO I=1,sNx
392                  II=((ip-1)*nSx+(bi-1))*sNx+I
393                  arr_gl(i,bi,ip,j,bj,jp,k) = global(II,JJ)
394                 ENDDO
395                ENDDO
396               ENDDO
397              ENDDO
398             ENDDO
399            ENDDO
400    
401           ENDDO
402    c      ENDDO k=1,nNz
403    
404            close( dUnit )
405    
406          endif
407    c      end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
408    
409        _END_MASTER( myThid )        _END_MASTER( myThid )
410    
411    #else /* ALLOW_CTRL */
412          STOP 'ABNORMAL END: S/R MDSREADFIELD_3D_GL is empty'
413    #endif /* ALLOW_CTRL */
414  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
415        return        RETURN
416        end        END
417  C=======================================================================  
418    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
419    
 C=======================================================================  
420        SUBROUTINE MDSWRITEFIELD_3D_GL(        SUBROUTINE MDSWRITEFIELD_3D_GL(
421       I   fName,       I   fName,
422       I   filePrec,       I   filePrec,
# Line 278  C======================================= Line 429  C=======================================
429  C  C
430  C Arguments:  C Arguments:
431  C  C
432  C fName         string  base name for file to written  C fName     (string)  :: base name for file to write
433  C filePrec      integer number of bits per word in file (32 or 64)  C filePrec  (integer) :: number of bits per word in file (32 or 64)
434  C arrType       char(2) declaration of "arr": either "RS" or "RL"  C arrType   (char(2)) :: type of array "arr": either "RS" or "RL"
435  C nNz           integer size of third dimension: normally either 1 or Nr  C nNz       (integer) :: size of third dimension: normally either 1 or Nr
436  C arr           RS/RL   array to write, arr(:,:,nNz,:,:)  C arr        (RS/RL)  :: array to write, arr(:,:,nNz,:,:)
437  C irecord       integer record number to read  C irecord   (integer) :: record number to write
438  C myIter        integer time step number  C myIter    (integer) :: time step number
439  C myThid        integer thread identifier  C myThid    (integer) :: thread identifier
440  C  C
441  C MDSWRITEFIELD creates either a file of the form "fName.data" and  C MDSWRITEFIELD creates either a file of the form "fName.data" and
442  C "fName.meta" if the logical flag "globalFile" is set true. Otherwise  C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
# Line 330  cph) Line 481  cph)
481        integer irecord        integer irecord
482        integer myIter        integer myIter
483        integer myThid        integer myThid
484    
485    #ifdef ALLOW_CTRL
486    
487  C Functions  C Functions
488        integer ILNBLNK        integer ILNBLNK
489        integer MDS_RECLEN        integer MDS_RECLEN
490  C Local variables  C Local variables
491        character*(80) dataFName,metaFName        character*(MAX_LEN_FNAM) dataFName,metaFName
492        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
493        Real*4 r4seg(sNx)        Real*4 r4seg(sNx)
494        Real*8 r8seg(sNx)        Real*8 r8seg(sNx)
495        _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)
496        integer dimList(3,3),ndims        INTEGER dimList(3,3), nDims, map2gl(2)
497          _RL dummyRL(1)
498          CHARACTER*8 blank8c
499        integer length_of_rec        integer length_of_rec
500        logical fileIsOpen        logical fileIsOpen
501        character*(max_len_mbuf) msgbuf        character*(max_len_mbuf) msgbuf
502    cph-usesingle(
503    #ifdef ALLOW_USE_MPI
504          integer ii,jj
505    c     integer iG_IO,jG_IO,npe
506          integer x_size,y_size
507          PARAMETER ( x_size = Nx )
508          PARAMETER ( y_size = Ny )
509          Real*4 xy_buffer_r4(x_size,y_size)
510          Real*8 xy_buffer_r8(x_size,y_size)
511          Real*8 global(Nx,Ny)
512    #endif
513    cph-usesingle)
514    CMM(
515          integer pIL
516    CMM)
517    
518          DATA dummyRL(1) / 0. _d 0 /
519          DATA blank8c / '        ' /
520    
521  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
522    
523  C Only do I/O if I am the master thread  C Only do I/O if I am the master thread
524        _BEGIN_MASTER( myThid )        _BEGIN_MASTER( myThid )
525    
526    #ifndef REAL4_IS_SLOW
527          if (arrType .eq. 'RS') then
528           write(msgbuf,'(a)')
529         &   ' MDSWRITEFIELD_GL is wrong for arrType="RS" (=real*4)'
530           call print_error( msgbuf, mythid )
531           stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
532          endif
533    #endif
534    
535  C Record number must be >= 1  C Record number must be >= 1
536        if (irecord .LT. 1) then        if (irecord .LT. 1) then
537         write(msgbuf,'(a,i9.8)')         write(msgbuf,'(a,i9.8)')
# Line 363  C Record number must be >= 1 Line 547  C Record number must be >= 1
547  C Assume nothing  C Assume nothing
548        fileIsOpen=.FALSE.        fileIsOpen=.FALSE.
549        IL=ILNBLNK( fName )        IL=ILNBLNK( fName )
550    CMM(
551          pIL = ILNBLNK( mdsioLocalDir )
552    CMM)
553    CMM(
554    C Assign special directory
555          if ( pIL.NE.0 ) then
556           write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
557          endif
558    CMM)
559    
560  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
561        call MDSFINDUNIT( dUnit, mythid )        call MDSFINDUNIT( dUnit, mythid )
562    
563    cph-usesingle(
564    #ifdef ALLOW_USE_MPI
565          _END_MASTER( myThid )
566    C If option globalFile is desired but does not work or if
567    C globalFile is too slow, then try using single-CPU I/O.
568          if (useSingleCpuIO) then
569    
570    C Master thread of process 0, only, opens a global file
571           _BEGIN_MASTER( myThid )
572            IF( myProcId .EQ. 0 ) THEN
573             write(dataFname,'(2a)') fName(1:IL),'.data'
574             length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
575             if (irecord .EQ. 1) then
576              open( dUnit, file=dataFName, status=_NEW_STATUS,
577         &        access='direct', recl=length_of_rec )
578             else
579              open( dUnit, file=dataFName, status=_OLD_STATUS,
580         &        access='direct', recl=length_of_rec )
581             endif
582            ENDIF
583           _END_MASTER( myThid )
584    
585  C Loop over all processors      C Gather array and write it to file, one vertical level at a time
586           DO k=1,nNz
587    C Loop over all processors
588            do jp=1,nPy
589            do ip=1,nPx
590            DO bj = myByLo(myThid), myByHi(myThid)
591             DO bi = myBxLo(myThid), myBxHi(myThid)
592              DO J=1,sNy
593               JJ=((jp-1)*nSy+(bj-1))*sNy+J
594               DO I=1,sNx
595                II=((ip-1)*nSx+(bi-1))*sNx+I
596                global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
597               ENDDO
598              ENDDO
599             ENDDO
600            ENDDO
601            enddo
602            enddo
603            _BEGIN_MASTER( myThid )
604             IF( myProcId .EQ. 0 ) THEN
605              irec=k+nNz*(irecord-1)
606              if (filePrec .eq. precFloat32) then
607               DO J=1,Ny
608                DO I=1,Nx
609                 xy_buffer_r4(I,J) = global(I,J)
610                ENDDO
611               ENDDO
612    #ifdef _BYTESWAPIO
613               call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
614    #endif
615               write(dUnit,rec=irec) xy_buffer_r4
616              elseif (filePrec .eq. precFloat64) then
617               DO J=1,Ny
618                DO I=1,Nx
619                 xy_buffer_r8(I,J) = global(I,J)
620                ENDDO
621               ENDDO
622    #ifdef _BYTESWAPIO
623               call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
624    #endif
625               write(dUnit,rec=irec) xy_buffer_r8
626              else
627               write(msgbuf,'(a)')
628         &       ' MDSWRITEFIELD: illegal value for filePrec'
629               call print_error( msgbuf, mythid )
630               stop 'ABNORMAL END: S/R MDSWRITEFIELD'
631              endif
632             ENDIF
633            _END_MASTER( myThid )
634           ENDDO
635    
636    C Close data-file and create meta-file
637           _BEGIN_MASTER( myThid )
638            IF( myProcId .EQ. 0 ) THEN
639             close( dUnit )
640             write(metaFName,'(2a)') fName(1:IL),'.meta'
641             dimList(1,1)=Nx
642             dimList(2,1)=1
643             dimList(3,1)=Nx
644             dimList(1,2)=Ny
645             dimList(2,2)=1
646             dimList(3,2)=Ny
647             dimList(1,3)=nNz
648             dimList(2,3)=1
649             dimList(3,3)=nNz
650             nDims=3
651             if (nNz .EQ. 1) nDims=2
652             map2gl(1) = 0
653             map2gl(2) = 1
654             CALL MDS_WRITE_META(
655         I              metaFName, dataFName, the_run_name, ' ',
656         I              filePrec, nDims, dimList, map2gl, 0, blank8c,
657         I              0, dummyRL, oneRL, irecord, myIter, myThid )
658            ENDIF
659           _END_MASTER( myThid )
660    C To be safe, make other processes wait for I/O completion
661           _BARRIER
662    
663          elseif ( .NOT. useSingleCpuIO ) then
664          _BEGIN_MASTER( myThid )
665    #endif /* ALLOW_USE_MPI */
666    cph-usesingle)
667    
668    C Loop over all processors
669        do jp=1,nPy        do jp=1,nPy
670        do ip=1,nPx        do ip=1,nPx
671  C Loop over all tiles  C Loop over all tiles
# Line 377  C Loop over all tiles Line 674  C Loop over all tiles
674  C If we are writing to a tiled MDS file then we open each one here  C If we are writing to a tiled MDS file then we open each one here
675           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
676           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
677           write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')           write(dataFname,'(2a,i3.3,a,i3.3,a)')
678       &              fName(1:IL),'.',iG,'.',jG,'.data'       &              fName(1:IL),'.',iG,'.',jG,'.data'
679           if (irecord .EQ. 1) then           if (irecord .EQ. 1) then
680            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
# Line 393  C If we are writing to a tiled MDS file Line 690  C If we are writing to a tiled MDS file
690          if (fileIsOpen) then          if (fileIsOpen) then
691           do k=1,Nr           do k=1,Nr
692            do j=1,sNy            do j=1,sNy
693               do ii=1,sNx               do i=1,sNx
694                  arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)                  arr(i,j,k,bi,bj)=arr_gl(i,bi,ip,j,bj,jp,k)
695               enddo               enddo
696              iG = 0              iG = 0
697              jG = 0              jG = 0
698              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
699             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
700              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
701    #ifdef REAL4_IS_SLOW
702               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .FALSE., arr )               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
703    #endif
704              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
705               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .FALSE., arr )               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
706              else              else
# Line 416  C If we are writing to a tiled MDS file Line 715  C If we are writing to a tiled MDS file
715              write(dUnit,rec=irec) r4seg              write(dUnit,rec=irec) r4seg
716             elseif (filePrec .eq. precFloat64) then             elseif (filePrec .eq. precFloat64) then
717              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
718    #ifdef REAL4_IS_SLOW
719               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .FALSE., arr )               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
720    #endif
721              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
722               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .FALSE., arr )               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
723              else              else
# Line 453  C If we were writing to a tiled MDS file Line 754  C If we were writing to a tiled MDS file
754  C Create meta-file for each tile if we are tiling  C Create meta-file for each tile if we are tiling
755           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
756           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
757           write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')           write(metaFname,'(2a,i3.3,a,i3.3,a)')
758       &              fName(1:IL),'.',iG,'.',jG,'.meta'       &              fName(1:IL),'.',iG,'.',jG,'.meta'
759           dimList(1,1)=Nx           dimList(1,1)=Nx
760           dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1           dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
# Line 464  C Create meta-file for each tile if we a Line 765  C Create meta-file for each tile if we a
765           dimList(1,3)=Nr           dimList(1,3)=Nr
766           dimList(2,3)=1           dimList(2,3)=1
767           dimList(3,3)=Nr           dimList(3,3)=Nr
768           ndims=3           nDims=3
769           if (Nr .EQ. 1) ndims=2           if (Nr .EQ. 1) nDims=2
770           call MDSWRITEMETA( metaFName, dataFName,           map2gl(1) = 0
771       &     filePrec, ndims, dimList, irecord, myIter, mythid )           map2gl(2) = 1
772             CALL MDS_WRITE_META(
773         I              metaFName, dataFName, the_run_name, ' ',
774         I              filePrec, nDims, dimList, map2gl, 0, blank8c,
775         I              0, dummyRL, oneRL, irecord, myIter, myThid )
776  C End of bi,bj loops  C End of bi,bj loops
777         enddo         enddo
778        enddo        enddo
# Line 475  C End of ip,jp loops Line 780  C End of ip,jp loops
780         enddo         enddo
781        enddo        enddo
782    
   
783        _END_MASTER( myThid )        _END_MASTER( myThid )
784    
785    cph-usesingle(
786    #ifdef ALLOW_USE_MPI
787    C endif useSingleCpuIO
788          endif
789    #endif /* ALLOW_USE_MPI */
790    cph-usesingle)
791    
792    #else /* ALLOW_CTRL */
793          STOP 'ABNORMAL END: S/R MDSWRITEFIELD_3D_GL is empty'
794    #endif /* ALLOW_CTRL */
795  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
796        return        RETURN
797        end        END
798  C=======================================================================  
799    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
800    
 C=======================================================================  
801        SUBROUTINE MDSREADFIELD_2D_GL(        SUBROUTINE MDSREADFIELD_2D_GL(
802       I   fName,       I   fName,
803       I   filePrec,       I   filePrec,
# Line 495  C======================================= Line 809  C=======================================
809  C  C
810  C Arguments:  C Arguments:
811  C  C
812  C fName         string  base name for file to read  C fName     (string)  :: base name for file to read
813  C filePrec      integer number of bits per word in file (32 or 64)  C filePrec  (integer) :: number of bits per word in file (32 or 64)
814  C arrType       char(2) declaration of "arr": either "RS" or "RL"  C arrType   (char(2)) :: type of array "arr": either "RS" or "RL"
815  C nNz           integer size of third dimension: normally either 1 or Nr  C nNz       (integer) :: size of third dimension: normally either 1 or Nr
816  C arr           RS/RL   array to read into, arr(:,:,nNz,:,:)  C arr        (RS/RL)  :: array to read into, arr(:,:,nNz,:,:)
817  C irecord       integer record number to read  C irecord   (integer) :: record number to read
818  C myThid        integer thread identifier  C myThid    (integer) :: thread identifier
819  C  C
820  C MDSREADFIELD first checks to see if the file "fName" exists, then  C MDSREADFIELD first checks to see if the file "fName" exists, then
821  C if the file "fName.data" exists and finally the tiled files of the  C if the file "fName.data" exists and finally the tiled files of the
# Line 535  C Routine arguments Line 849  C Routine arguments
849        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
850        integer irecord        integer irecord
851        integer myThid        integer myThid
852    
853    #ifdef ALLOW_CTRL
854    
855  C Functions  C Functions
856        integer ILNBLNK        integer ILNBLNK
857        integer MDS_RECLEN        integer MDS_RECLEN
858  C Local variables  C Local variables
859        character*(80) dataFName        character*(MAX_LEN_FNAM) dataFName
860        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
861        logical exst        logical exst
862        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
863        Real*4 r4seg(sNx)        Real*4 r4seg(sNx)
# Line 548  C Local variables Line 865  C Local variables
865        logical globalFile,fileIsOpen        logical globalFile,fileIsOpen
866        integer length_of_rec        integer length_of_rec
867        character*(max_len_mbuf) msgbuf        character*(max_len_mbuf) msgbuf
868    cph-usesingle(
869          integer ii,jj
870    c     integer iG_IO,jG_IO,npe
871          integer x_size,y_size
872          PARAMETER ( x_size = Nx )
873          PARAMETER ( y_size = Ny )
874          Real*4 xy_buffer_r4(x_size,y_size)
875          Real*8 xy_buffer_r8(x_size,y_size)
876          Real*8 global(Nx,Ny)
877    c     _RL    local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
878    cph-usesingle)
879    CMM(
880          integer pIL
881    CMM)
882    
883  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
884    
885  C Only do I/O if I am the master thread  C Only do I/O if I am the master thread
886        _BEGIN_MASTER( myThid )        _BEGIN_MASTER( myThid )
887    
888    #ifndef REAL4_IS_SLOW
889          if (arrType .eq. 'RS') then
890           write(msgbuf,'(a)')
891         &   ' MDSREADFIELD_GL is wrong for arrType="RS" (=real*4)'
892           call print_error( msgbuf, mythid )
893           stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
894          endif
895    #endif
896    
897  C Record number must be >= 1  C Record number must be >= 1
898        if (irecord .LT. 1) then        if (irecord .LT. 1) then
899         write(msgbuf,'(a,i9.8)')         write(msgbuf,'(a,i9.8)')
# Line 569  C Assume nothing Line 910  C Assume nothing
910        globalFile = .FALSE.        globalFile = .FALSE.
911        fileIsOpen = .FALSE.        fileIsOpen = .FALSE.
912        IL=ILNBLNK( fName )        IL=ILNBLNK( fName )
913    CMM(
914          pIL = ILNBLNK( mdsioLocalDir )
915    CMM)
916    CMM(
917    C Assign special directory
918          if ( pIL.NE.0 ) then
919           write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
920          endif
921    CMM)
922    
923  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
924        call MDSFINDUNIT( dUnit, mythid )        call MDSFINDUNIT( dUnit, mythid )
925    
926          if ( useSingleCPUIO ) then
927    
928    C master thread of process 0, only, opens a global file
929    #ifdef ALLOW_USE_MPI
930            IF( myProcId .EQ. 0 ) THEN
931    #else
932            IF ( .TRUE. ) THEN
933    #endif /* ALLOW_USE_MPI */
934    
935  C Check first for global file with simple name (ie. fName)  C Check first for global file with simple name (ie. fName)
936        dataFName = fName           dataFName = fName
937        inquire( file=dataFname, exist=exst )           inquire( file=dataFname, exist=exst )
938        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  
939    
940  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)
941        if (.NOT. globalFile) then           if (.NOT. globalFile) then
942         write(dataFname(1:80),'(2a)') fName(1:IL),'.data'            write(dataFname,'(2a)') fName(1:IL),'.data'
943              inquire( file=dataFname, exist=exst )
944              if (exst) globalFile = .TRUE.
945             endif
946    
947    C If global file is visible to process 0, then open it here.
948    C Otherwise stop program.
949             if ( globalFile) then
950              length_of_rec=MDS_RECLEN( filePrec, x_size*y_size, mythid )
951              open( dUnit, file=dataFName, status='old',
952         &         access='direct', recl=length_of_rec )
953             else
954              write(msgbuf,'(2a)')
955         &      ' MDSREADFIELD: filename: ',dataFName(1:IL)
956              call print_message( msgbuf, standardmessageunit,
957         &                        SQUEEZE_RIGHT , mythid)
958              call print_error( msgbuf, mythid )
959              write(msgbuf,'(a)')
960         &      ' MDSREADFIELD: File does not exist'
961              call print_message( msgbuf, standardmessageunit,
962         &                        SQUEEZE_RIGHT , mythid)
963              call print_error( msgbuf, mythid )
964              stop 'ABNORMAL END: S/R MDSREADFIELD'
965             endif
966    
967            ENDIF
968    
969    c-- useSingleCpuIO
970          else
971    
972    C Check first for global file with simple name (ie. fName)
973           dataFName = fName
974         inquire( file=dataFname, exist=exst )         inquire( file=dataFname, exist=exst )
975         if (exst) then         if (exst) then
976          write(msgbuf,'(a,a)')          write(msgbuf,'(a,a)')
977       &    ' MDSREADFIELD_GL: opening global file: ',dataFName       &    ' MDSREADFIELD: opening global file: ',dataFName(1:IL)
978          call print_message( msgbuf, standardmessageunit,          call print_message( msgbuf, standardmessageunit,
979       &                      SQUEEZE_RIGHT , mythid)       &                      SQUEEZE_RIGHT , mythid)
         globalFile = .TRUE.  
        stop " xx, adxx, weights and masks are not supposed to be global"  
980         endif         endif
981    
982    C If negative check for global file with MDS name (ie. fName.data)
983           if (.NOT. globalFile) then
984            write(dataFname,'(2a)') fName(1:IL),'.data'
985            inquire( file=dataFname, exist=exst )
986            if (exst) then
987             write(msgbuf,'(a,a)')
988         &     ' MDSREADFIELD_GL: opening global file: ',dataFName(1:IL+5)
989             call print_message( msgbuf, standardmessageunit,
990         &                       SQUEEZE_RIGHT , mythid)
991             globalFile = .TRUE.
992            endif
993           endif
994    
995    c-- useSingleCpuIO
996          endif
997    
998          if ( .not. useSingleCpuIO ) then
999    cph      if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
1000          if ( .not. ( globalFile ) ) then
1001    
1002    C If we are reading from a global file then we open it here
1003          if (globalFile) then
1004           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1005           open( dUnit, file=dataFName, status='old',
1006         &      access='direct', recl=length_of_rec )
1007           fileIsOpen=.TRUE.
1008        endif        endif
1009  C Loop over all processors      
1010    C Loop over all processors
1011        do jp=1,nPy        do jp=1,nPy
1012        do ip=1,nPx        do ip=1,nPx
1013  C Loop over all tiles  C Loop over all tiles
# Line 607  C If we are reading from a tiled MDS fil Line 1017  C If we are reading from a tiled MDS fil
1017          if (.NOT. globalFile) then          if (.NOT. globalFile) then
1018           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1019           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1020           write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')           write(dataFname,'(2a,i3.3,a,i3.3,a)')
1021       &              fName(1:IL),'.',iG,'.',jG,'.data'       &              fName(1:IL),'.',iG,'.',jG,'.data'
1022           inquire( file=dataFname, exist=exst )           inquire( file=dataFname, exist=exst )
1023  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"
1024  C (This is a place-holder for the active/passive mechanism  C (This is a place-holder for the active/passive mechanism
1025           if (exst) then           if (exst) then
1026            write(msgbuf,'(a,a)')            if ( debugLevel .GE. debLevB ) then
1027       &      ' MDSREADFIELD_GL: opening file: ',dataFName             write(msgbuf,'(a,a)')
1028            call print_message( msgbuf, standardmessageunit,       &      ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)
1029               call print_message( msgbuf, standardmessageunit,
1030       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
1031              endif
1032            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1033            open( dUnit, file=dataFName, status='old',            open( dUnit, file=dataFName, status='old',
1034       &        access='direct', recl=length_of_rec )       &        access='direct', recl=length_of_rec )
# Line 624  C (This is a place-holder for the active Line 1036  C (This is a place-holder for the active
1036           else           else
1037            fileIsOpen=.FALSE.            fileIsOpen=.FALSE.
1038            write(msgbuf,'(a,a)')            write(msgbuf,'(a,a)')
1039       &      ' MDSREADFIELD_GL: filename: ',dataFName       &      ' MDSREADFIELD_GL: filename: ',dataFName(1:IL+13)
1040            call print_message( msgbuf, standardmessageunit,            call print_message( msgbuf, standardmessageunit,
1041       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
1042              call print_error( msgbuf, mythid )
1043            write(msgbuf,'(a)')            write(msgbuf,'(a)')
1044       &      ' MDSREADFIELD_GL: File does not exist'       &      ' MDSREADFIELD_GL: File does not exist'
1045              call print_message( msgbuf, standardmessageunit,
1046         &                        SQUEEZE_RIGHT , mythid)
1047            call print_error( msgbuf, mythid )            call print_error( msgbuf, mythid )
1048            stop 'ABNORMAL END: S/R MDSREADFIELD_GL'            stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
1049           endif           endif
# Line 637  C (This is a place-holder for the active Line 1052  C (This is a place-holder for the active
1052          if (fileIsOpen) then          if (fileIsOpen) then
1053           do k=1,nLocz           do k=1,nLocz
1054            do j=1,sNy            do j=1,sNy
1055               if (globalFile) then
1056                iG=bi+(ip-1)*nsx
1057                jG=bj+(jp-1)*nsy
1058                irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
1059         &             + nSx*nPx*Ny*nLocz*(irecord-1)
1060               else
1061              iG = 0              iG = 0
1062              jG = 0              jG = 0
1063              irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)              irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
1064               endif
1065             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
1066              read(dUnit,rec=irec) r4seg              read(dUnit,rec=irec) r4seg
1067  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
1068              call MDS_BYTESWAPR4( sNx, r4seg )              call MDS_BYTESWAPR4( sNx, r4seg )
1069  #endif  #endif
1070              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
1071    #ifdef REAL4_IS_SLOW
1072               call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )               call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
1073    #endif
1074              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
1075               call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )               call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
1076              else              else
# Line 661  C (This is a place-holder for the active Line 1085  C (This is a place-holder for the active
1085              call MDS_BYTESWAPR8( sNx, r8seg )              call MDS_BYTESWAPR8( sNx, r8seg )
1086  #endif  #endif
1087              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
1088    #ifdef REAL4_IS_SLOW
1089               call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )               call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
1090    #endif
1091              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
1092               call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )               call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
1093              else              else
# Line 702  C If global file was opened then close i Line 1128  C If global file was opened then close i
1128         fileIsOpen = .FALSE.         fileIsOpen = .FALSE.
1129        endif        endif
1130    
1131    c      end of if ( .not. ( globalFile ) ) then
1132          endif
1133    
1134    c      else of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
1135          else
1136    
1137           DO k=1,nLocz
1138    
1139    #ifdef ALLOW_USE_MPI
1140             IF( myProcId .EQ. 0 ) THEN
1141    #else
1142             IF ( .TRUE. ) THEN
1143    #endif /* ALLOW_USE_MPI */
1144              irec = k+nNz*(irecord-1)
1145              if (filePrec .eq. precFloat32) then
1146               read(dUnit,rec=irec) xy_buffer_r4
1147    #ifdef _BYTESWAPIO
1148               call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
1149    #endif
1150               DO J=1,Ny
1151                DO I=1,Nx
1152                 global(I,J) = xy_buffer_r4(I,J)
1153                ENDDO
1154               ENDDO
1155              elseif (filePrec .eq. precFloat64) then
1156               read(dUnit,rec=irec) xy_buffer_r8
1157    #ifdef _BYTESWAPIO
1158               call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
1159    #endif
1160               DO J=1,Ny
1161                DO I=1,Nx
1162                 global(I,J) = xy_buffer_r8(I,J)
1163                ENDDO
1164               ENDDO
1165              else
1166               write(msgbuf,'(a)')
1167         &            ' MDSREADFIELD: illegal value for filePrec'
1168               call print_error( msgbuf, mythid )
1169               stop 'ABNORMAL END: S/R MDSREADFIELD'
1170              endif
1171             ENDIF
1172            DO jp=1,nPy
1173             DO ip=1,nPx
1174              DO bj = myByLo(myThid), myByHi(myThid)
1175               DO bi = myBxLo(myThid), myBxHi(myThid)
1176                DO J=1,sNy
1177                 JJ=((jp-1)*nSy+(bj-1))*sNy+J
1178                 DO I=1,sNx
1179                  II=((ip-1)*nSx+(bi-1))*sNx+I
1180                  arr_gl(i,bi,ip,j,bj,jp,k) = global(II,JJ)
1181                 ENDDO
1182                ENDDO
1183               ENDDO
1184              ENDDO
1185             ENDDO
1186            ENDDO
1187    
1188           ENDDO
1189    c      ENDDO k=1,nNz
1190    
1191            close( dUnit )
1192    
1193          endif
1194    c      end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
1195    
1196        _END_MASTER( myThid )        _END_MASTER( myThid )
1197    
1198    #else /* ALLOW_CTRL */
1199          STOP 'ABNORMAL END: S/R MDSREADFIELD_2D_GL is empty'
1200    #endif /* ALLOW_CTRL */
1201  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
1202        return        RETURN
1203        end        END
1204  C=======================================================================  
1205    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
1206    
 C=======================================================================  
1207        SUBROUTINE MDSWRITEFIELD_2D_GL(        SUBROUTINE MDSWRITEFIELD_2D_GL(
1208       I   fName,       I   fName,
1209       I   filePrec,       I   filePrec,
# Line 722  C======================================= Line 1216  C=======================================
1216  C  C
1217  C Arguments:  C Arguments:
1218  C  C
1219  C fName         string  base name for file to written  C fName     (string)  :: base name for file to write
1220  C filePrec      integer number of bits per word in file (32 or 64)  C filePrec  (integer) :: number of bits per word in file (32 or 64)
1221  C arrType       char(2) declaration of "arr": either "RS" or "RL"  C arrType   (char(2)) :: type of array "arr": either "RS" or "RL"
1222  C nNz           integer size of third dimension: normally either 1 or Nr  C nNz       (integer) :: size of third dimension: normally either 1 or Nr
1223  C arr           RS/RL   array to write, arr(:,:,nNz,:,:)  C arr        (RS/RL)  :: array to write, arr(:,:,nNz,:,:)
1224  C irecord       integer record number to read  C irecord   (integer) :: record number to write
1225  C myIter        integer time step number  C myIter    (integer) :: time step number
1226  C myThid        integer thread identifier  C myThid    (integer) :: thread identifier
1227  C  C
1228  C MDSWRITEFIELD creates either a file of the form "fName.data" and  C MDSWRITEFIELD creates either a file of the form "fName.data" and
1229  C "fName.meta" if the logical flag "globalFile" is set true. Otherwise  C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
# Line 775  cph) Line 1269  cph)
1269        integer irecord        integer irecord
1270        integer myIter        integer myIter
1271        integer myThid        integer myThid
1272    
1273    #ifdef ALLOW_CTRL
1274    
1275  C Functions  C Functions
1276        integer ILNBLNK        integer ILNBLNK
1277        integer MDS_RECLEN        integer MDS_RECLEN
1278  C Local variables  C Local variables
1279        character*(80) dataFName,metaFName        character*(MAX_LEN_FNAM) dataFName,metaFName
1280        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
1281        Real*4 r4seg(sNx)        Real*4 r4seg(sNx)
1282        Real*8 r8seg(sNx)        Real*8 r8seg(sNx)
1283        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
1284        integer dimList(3,3),ndims        INTEGER dimList(3,3), nDims, map2gl(2)
1285          _RL dummyRL(1)
1286          CHARACTER*8 blank8c
1287        integer length_of_rec        integer length_of_rec
1288        logical fileIsOpen        logical fileIsOpen
1289        character*(max_len_mbuf) msgbuf        character*(max_len_mbuf) msgbuf
1290    cph-usesingle(
1291    #ifdef ALLOW_USE_MPI
1292          integer ii,jj
1293    c     integer iG_IO,jG_IO,npe
1294          integer x_size,y_size
1295          PARAMETER ( x_size = Nx )
1296          PARAMETER ( y_size = Ny )
1297          Real*4 xy_buffer_r4(x_size,y_size)
1298          Real*8 xy_buffer_r8(x_size,y_size)
1299          Real*8 global(Nx,Ny)
1300    #endif
1301    cph-usesingle)
1302    CMM(
1303          integer pIL
1304    CMM)
1305    
1306          DATA dummyRL(1) / 0. _d 0 /
1307          DATA blank8c / '        ' /
1308    
1309  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
1310    
1311  C Only do I/O if I am the master thread  C Only do I/O if I am the master thread
1312        _BEGIN_MASTER( myThid )        _BEGIN_MASTER( myThid )
1313    
1314    #ifndef REAL4_IS_SLOW
1315          if (arrType .eq. 'RS') then
1316           write(msgbuf,'(a)')
1317         &   ' MDSWRITEFIELD_GL is wrong for arrType="RS" (=real*4)'
1318           call print_error( msgbuf, mythid )
1319           stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1320          endif
1321    #endif
1322    
1323  C Record number must be >= 1  C Record number must be >= 1
1324        if (irecord .LT. 1) then        if (irecord .LT. 1) then
1325         write(msgbuf,'(a,i9.8)')         write(msgbuf,'(a,i9.8)')
# Line 808  C Record number must be >= 1 Line 1335  C Record number must be >= 1
1335  C Assume nothing  C Assume nothing
1336        fileIsOpen=.FALSE.        fileIsOpen=.FALSE.
1337        IL=ILNBLNK( fName )        IL=ILNBLNK( fName )
1338    CMM(
1339          pIL = ILNBLNK( mdsioLocalDir )
1340    CMM)
1341    CMM(
1342    C Assign special directory
1343          if ( pIL.NE.0 ) then
1344           write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
1345          endif
1346    CMM)
1347    
1348  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
1349        call MDSFINDUNIT( dUnit, mythid )        call MDSFINDUNIT( dUnit, mythid )
1350    
1351    
1352  C Loop over all processors      cph-usesingle(
1353    #ifdef ALLOW_USE_MPI
1354          _END_MASTER( myThid )
1355    C If option globalFile is desired but does not work or if
1356    C globalFile is too slow, then try using single-CPU I/O.
1357          if (useSingleCpuIO) then
1358    
1359    C Master thread of process 0, only, opens a global file
1360           _BEGIN_MASTER( myThid )
1361            IF( myProcId .EQ. 0 ) THEN
1362             write(dataFname,'(2a)') fName(1:IL),'.data'
1363             length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
1364             if (irecord .EQ. 1) then
1365              open( dUnit, file=dataFName, status=_NEW_STATUS,
1366         &        access='direct', recl=length_of_rec )
1367             else
1368              open( dUnit, file=dataFName, status=_OLD_STATUS,
1369         &        access='direct', recl=length_of_rec )
1370             endif
1371            ENDIF
1372           _END_MASTER( myThid )
1373    
1374    C Gather array and write it to file, one vertical level at a time
1375           DO k=1,nLocz
1376    C Loop over all processors
1377            do jp=1,nPy
1378            do ip=1,nPx
1379            DO bj = myByLo(myThid), myByHi(myThid)
1380             DO bi = myBxLo(myThid), myBxHi(myThid)
1381              DO J=1,sNy
1382               JJ=((jp-1)*nSy+(bj-1))*sNy+J
1383               DO I=1,sNx
1384                II=((ip-1)*nSx+(bi-1))*sNx+I
1385                global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
1386               ENDDO
1387              ENDDO
1388             ENDDO
1389            ENDDO
1390            enddo
1391            enddo
1392            _BEGIN_MASTER( myThid )
1393             IF( myProcId .EQ. 0 ) THEN
1394              irec=k+nLocz*(irecord-1)
1395              if (filePrec .eq. precFloat32) then
1396               DO J=1,Ny
1397                DO I=1,Nx
1398                 xy_buffer_r4(I,J) = global(I,J)
1399                ENDDO
1400               ENDDO
1401    #ifdef _BYTESWAPIO
1402               call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
1403    #endif
1404               write(dUnit,rec=irec) xy_buffer_r4
1405              elseif (filePrec .eq. precFloat64) then
1406               DO J=1,Ny
1407                DO I=1,Nx
1408                 xy_buffer_r8(I,J) = global(I,J)
1409                ENDDO
1410               ENDDO
1411    #ifdef _BYTESWAPIO
1412               call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
1413    #endif
1414               write(dUnit,rec=irec) xy_buffer_r8
1415              else
1416               write(msgbuf,'(a)')
1417         &       ' MDSWRITEFIELD: illegal value for filePrec'
1418               call print_error( msgbuf, mythid )
1419               stop 'ABNORMAL END: S/R MDSWRITEFIELD'
1420              endif
1421             ENDIF
1422            _END_MASTER( myThid )
1423           ENDDO
1424    
1425    C Close data-file and create meta-file
1426           _BEGIN_MASTER( myThid )
1427            IF( myProcId .EQ. 0 ) THEN
1428             close( dUnit )
1429             write(metaFName,'(2a)') fName(1:IL),'.meta'
1430             dimList(1,1)=Nx
1431             dimList(2,1)=1
1432             dimList(3,1)=Nx
1433             dimList(1,2)=Ny
1434             dimList(2,2)=1
1435             dimList(3,2)=Ny
1436             dimList(1,3)=nLocz
1437             dimList(2,3)=1
1438             dimList(3,3)=nLocz
1439             nDims=3
1440             if (nLocz .EQ. 1) nDims=2
1441             map2gl(1) = 0
1442             map2gl(2) = 1
1443             CALL MDS_WRITE_META(
1444         I              metaFName, dataFName, the_run_name, ' ',
1445         I              filePrec, nDims, dimList, map2gl, 0, blank8c,
1446         I              0, dummyRL, oneRL, irecord, myIter, myThid )
1447            ENDIF
1448           _END_MASTER( myThid )
1449    C To be safe, make other processes wait for I/O completion
1450           _BARRIER
1451    
1452          elseif ( .NOT. useSingleCpuIO ) then
1453          _BEGIN_MASTER( myThid )
1454    #endif /* ALLOW_USE_MPI */
1455    cph-usesingle)
1456    
1457    C Loop over all processors
1458        do jp=1,nPy        do jp=1,nPy
1459        do ip=1,nPx        do ip=1,nPx
1460  C Loop over all tiles  C Loop over all tiles
# Line 822  C Loop over all tiles Line 1463  C Loop over all tiles
1463  C If we are writing to a tiled MDS file then we open each one here  C If we are writing to a tiled MDS file then we open each one here
1464           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1465           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1466           write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')           write(dataFname,'(2a,i3.3,a,i3.3,a)')
1467       &              fName(1:IL),'.',iG,'.',jG,'.data'       &              fName(1:IL),'.',iG,'.',jG,'.data'
1468           if (irecord .EQ. 1) then           if (irecord .EQ. 1) then
1469            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
# Line 838  C If we are writing to a tiled MDS file Line 1479  C If we are writing to a tiled MDS file
1479          if (fileIsOpen) then          if (fileIsOpen) then
1480           do k=1,nLocz           do k=1,nLocz
1481            do j=1,sNy            do j=1,sNy
1482               do ii=1,sNx               do i=1,sNx
1483                  arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)                  arr(i,j,k,bi,bj)=arr_gl(i,bi,ip,j,bj,jp,k)
1484               enddo               enddo
1485              iG = 0              iG = 0
1486              jG = 0              jG = 0
1487              irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)              irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
1488             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
1489              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
1490    #ifdef REAL4_IS_SLOW
1491               call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )               call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1492    #endif
1493              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
1494               call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )               call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1495              else              else
# Line 861  C If we are writing to a tiled MDS file Line 1504  C If we are writing to a tiled MDS file
1504              write(dUnit,rec=irec) r4seg              write(dUnit,rec=irec) r4seg
1505             elseif (filePrec .eq. precFloat64) then             elseif (filePrec .eq. precFloat64) then
1506              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
1507    #ifdef REAL4_IS_SLOW
1508               call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )               call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1509    #endif
1510              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
1511               call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )               call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1512              else              else
# Line 898  C If we were writing to a tiled MDS file Line 1543  C If we were writing to a tiled MDS file
1543  C Create meta-file for each tile if we are tiling  C Create meta-file for each tile if we are tiling
1544           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles           iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1545           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles           jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1546           write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')           write(metaFname,'(2a,i3.3,a,i3.3,a)')
1547       &              fName(1:IL),'.',iG,'.',jG,'.meta'       &              fName(1:IL),'.',iG,'.',jG,'.meta'
1548           dimList(1,1)=Nx           dimList(1,1)=Nx
1549           dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1           dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
# Line 909  C Create meta-file for each tile if we a Line 1554  C Create meta-file for each tile if we a
1554           dimList(1,3)=Nr           dimList(1,3)=Nr
1555           dimList(2,3)=1           dimList(2,3)=1
1556           dimList(3,3)=Nr           dimList(3,3)=Nr
1557           ndims=3           nDims=3
1558           if (nLocz .EQ. 1) ndims=2           if (nLocz .EQ. 1) nDims=2
1559           call MDSWRITEMETA( metaFName, dataFName,           map2gl(1) = 0
1560       &     filePrec, ndims, dimList, irecord, myIter, mythid )           map2gl(2) = 1
1561             CALL MDS_WRITE_META(
1562         I              metaFName, dataFName, the_run_name, ' ',
1563         I              filePrec, nDims, dimList, map2gl, 0, blank8c,
1564         I              0, dummyRL, oneRL, irecord, myIter, myThid )
1565  C End of bi,bj loops  C End of bi,bj loops
1566         enddo         enddo
1567        enddo        enddo
# Line 920  C End of ip,jp loops Line 1569  C End of ip,jp loops
1569         enddo         enddo
1570        enddo        enddo
1571    
   
1572        _END_MASTER( myThid )        _END_MASTER( myThid )
1573    
1574    #ifdef ALLOW_USE_MPI
1575    C endif useSingleCpuIO
1576          endif
1577    #endif /* ALLOW_USE_MPI */
1578    
1579    #else /* ALLOW_CTRL */
1580          STOP 'ABNORMAL END: S/R MDSWRITEFIELD_2D_GL is empty'
1581    #endif /* ALLOW_CTRL */
1582  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
1583        return        RETURN
1584        end        END
 C=======================================================================  
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.21
  ViewVC Help
Powered by ViewVC 1.1.22