/[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.8 by heimbach, Wed Jan 12 20:33:13 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
# Line 64  C Local variables Line 85  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,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)
# Line 107  C Check first for global file with simpl Line 124  C Check first for global file with simpl
124       &   ' MDSREADFIELD: opening global file: ',dataFName       &   ' MDSREADFIELD: opening global file: ',dataFName
125         call print_message( msgbuf, standardmessageunit,         call print_message( msgbuf, standardmessageunit,
126       &                     SQUEEZE_RIGHT , mythid)       &                     SQUEEZE_RIGHT , mythid)
        stop " xx, adxx, weights and masks are not supposed to be global"  
127        endif        endif
128    
129  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)
# Line 120  C If negative check for global file with Line 136  C If negative check for global file with
136          call print_message( msgbuf, standardmessageunit,          call print_message( msgbuf, standardmessageunit,
137       &                      SQUEEZE_RIGHT , mythid)       &                      SQUEEZE_RIGHT , mythid)
138          globalFile = .TRUE.          globalFile = .TRUE.
        stop " xx, adxx, weights and masks are not supposed to be global"  
139         endif         endif
140        endif        endif
141    
142          if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
143    
144    C If we are reading from a global file then we open it here
145          if (globalFile) then
146           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
147           open( dUnit, file=dataFName, status='old',
148         &      access='direct', recl=length_of_rec )
149           fileIsOpen=.TRUE.
150          endif
151    
152  C Loop over all processors      C Loop over all processors    
153        do jp=1,nPy        do jp=1,nPy
154        do ip=1,nPx        do ip=1,nPx
# Line 139  C If we are reading from a tiled MDS fil Line 165  C If we are reading from a tiled MDS fil
165  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"
166  C (This is a place-holder for the active/passive mechanism  C (This is a place-holder for the active/passive mechanism
167           if (exst) then           if (exst) then
168            write(msgbuf,'(a,a)')            if ( debugLevel .GE. debLevA ) then
169               write(msgbuf,'(a,a)')
170       &      ' MDSREADFIELD_GL: opening file: ',dataFName       &      ' MDSREADFIELD_GL: opening file: ',dataFName
171            call print_message( msgbuf, standardmessageunit,             call print_message( msgbuf, standardmessageunit,
172       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
173              endif
174            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
175            open( dUnit, file=dataFName, status='old',            open( dUnit, file=dataFName, status='old',
176       &        access='direct', recl=length_of_rec )       &        access='direct', recl=length_of_rec )
# Line 153  C (This is a place-holder for the active Line 181  C (This is a place-holder for the active
181       &      ' MDSREADFIELD_GL: filename: ',dataFName       &      ' MDSREADFIELD_GL: filename: ',dataFName
182            call print_message( msgbuf, standardmessageunit,            call print_message( msgbuf, standardmessageunit,
183       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
184              call print_error( msgbuf, mythid )
185            write(msgbuf,'(a)')            write(msgbuf,'(a)')
186       &      ' MDSREADFIELD_GL: File does not exist'       &      ' MDSREADFIELD_GL: File does not exist'
187              call print_message( msgbuf, standardmessageunit,
188         &                        SQUEEZE_RIGHT , mythid)
189            call print_error( msgbuf, mythid )            call print_error( msgbuf, mythid )
190            stop 'ABNORMAL END: S/R MDSREADFIELD_GL'            stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
191           endif           endif
192          endif          endif
193    
194          if (fileIsOpen) then          if (fileIsOpen) then
195           do k=1,nNz           do k=1,Nr
196            do j=1,sNy            do j=1,sNy
197               if (globalFile) then
198                iG=bi+(ip-1)*nsx
199                jG=bj+(jp-1)*nsy
200                irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
201         &             + nSx*nPx*Ny*nNz*(irecord-1)
202               else
203              iG = 0              iG = 0
204              jG = 0              jG = 0
205              irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
206               endif
207             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
208              read(dUnit,rec=irec) r4seg              read(dUnit,rec=irec) r4seg
209  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
210              call MDS_BYTESWAPR4( sNx, r4seg )              call MDS_BYTESWAPR4( sNx, r4seg )
211  #endif  #endif
212              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
213               call MDS_SEG4toRS( j,bi,bj,k,nNz, r4seg, .TRUE., arr )               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
214              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
215               call MDS_SEG4toRL( j,bi,bj,k,nNz, r4seg, .TRUE., arr )               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
216              else              else
217               write(msgbuf,'(a)')               write(msgbuf,'(a)')
218       &         ' MDSREADFIELD_GL: illegal value for arrType'       &         ' MDSREADFIELD_GL: illegal value for arrType'
# Line 187  C (This is a place-holder for the active Line 225  C (This is a place-holder for the active
225              call MDS_BYTESWAPR8( sNx, r8seg )              call MDS_BYTESWAPR8( sNx, r8seg )
226  #endif  #endif
227              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
228               call MDS_SEG8toRS( j,bi,bj,k,nNz, r8seg, .TRUE., arr )               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
229              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
230               call MDS_SEG8toRL( j,bi,bj,k,nNz, r8seg, .TRUE., arr )               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
231              else              else
232               write(msgbuf,'(a)')               write(msgbuf,'(a)')
233       &         ' MDSREADFIELD_GL: illegal value for arrType'       &         ' MDSREADFIELD_GL: illegal value for arrType'
# Line 228  C If global file was opened then close i Line 266  C If global file was opened then close i
266         fileIsOpen = .FALSE.         fileIsOpen = .FALSE.
267        endif        endif
268    
269          endif
270    c      end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
271    
272        _END_MASTER( myThid )        _END_MASTER( myThid )
273    
274  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
# Line 236  C     ---------------------------------- Line 277  C     ----------------------------------
277  C=======================================================================  C=======================================================================
278    
279  C=======================================================================  C=======================================================================
280        SUBROUTINE MDSWRITEFIELD_GL(        SUBROUTINE MDSWRITEFIELD_3D_GL(
281       I   fName,       I   fName,
282       I   filePrec,       I   filePrec,
283       I   arrType,       I   arrType,
# Line 286  C          open(dUnit, ..., status='old' Line 327  C          open(dUnit, ..., status='old'
327  C Global variables / common blocks  C Global variables / common blocks
328  #include "SIZE.h"  #include "SIZE.h"
329  #include "EEPARAMS.h"  #include "EEPARAMS.h"
330    #include "EESUPPORT.h"
331  #include "PARAMS.h"  #include "PARAMS.h"
332    
333  C Routine arguments  C Routine arguments
# Line 295  C Routine arguments Line 337  C Routine arguments
337        integer nNz        integer nNz
338  cph(  cph(
339  cph      Real arr(*)  cph      Real arr(*)
340        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nNz)        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
341  cph)  cph)
342        integer irecord        integer irecord
343        integer myIter        integer myIter
# Line 305  C Functions Line 347  C Functions
347        integer MDS_RECLEN        integer MDS_RECLEN
348  C Local variables  C Local variables
349        character*(80) dataFName,metaFName        character*(80) dataFName,metaFName
350        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
351        Real*4 r4seg(sNx)        Real*4 r4seg(sNx)
352        Real*8 r8seg(sNx)        Real*8 r8seg(sNx)
353        _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 355  C Local variables
355        integer length_of_rec        integer length_of_rec
356        logical fileIsOpen        logical fileIsOpen
357        character*(max_len_mbuf) msgbuf        character*(max_len_mbuf) msgbuf
358    cph-usesingle(
359          integer ii,jj
360          integer x_size,y_size,iG_IO,jG_IO,npe
361          PARAMETER ( x_size = Nx )
362          PARAMETER ( y_size = Ny )
363          Real*4 xy_buffer_r4(x_size,y_size)
364          Real*8 xy_buffer_r8(x_size,y_size)
365          Real*8 global(Nx,Ny)
366    cph-usesingle)
367    
368  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
369    
370  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 389  C Assume nothing
389  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
390        call MDSFINDUNIT( dUnit, mythid )        call MDSFINDUNIT( dUnit, mythid )
391    
392    cph-usesingle(
393    #ifdef ALLOW_USE_MPI
394          _END_MASTER( myThid )
395    C If option globalFile is desired but does not work or if
396    C globalFile is too slow, then try using single-CPU I/O.
397          if (useSingleCpuIO) then
398    
399    C Master thread of process 0, only, opens a global file
400           _BEGIN_MASTER( myThid )
401            IF( mpiMyId .EQ. 0 ) THEN
402             write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
403             length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
404             if (irecord .EQ. 1) then
405              open( dUnit, file=dataFName, status=_NEW_STATUS,
406         &        access='direct', recl=length_of_rec )
407             else
408              open( dUnit, file=dataFName, status=_OLD_STATUS,
409         &        access='direct', recl=length_of_rec )
410             endif
411            ENDIF
412           _END_MASTER( myThid )
413    
414    C Gather array and write it to file, one vertical level at a time
415           DO k=1,nNz
416    C Loop over all processors    
417            do jp=1,nPy
418            do ip=1,nPx
419            DO bj = myByLo(myThid), myByHi(myThid)
420             DO bi = myBxLo(myThid), myBxHi(myThid)
421              DO J=1,sNy
422               JJ=((jp-1)*nSy+(bj-1))*sNy+J
423               DO I=1,sNx
424                II=((ip-1)*nSx+(bi-1))*sNx+I
425                global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
426               ENDDO
427              ENDDO
428             ENDDO
429            ENDDO
430            enddo
431            enddo
432            _BEGIN_MASTER( myThid )
433             IF( mpiMyId .EQ. 0 ) THEN
434              irec=k+nNz*(irecord-1)
435              if (filePrec .eq. precFloat32) then
436               DO J=1,Ny
437                DO I=1,Nx
438                 xy_buffer_r4(I,J) = global(I,J)
439                ENDDO
440               ENDDO
441    #ifdef _BYTESWAPIO
442               call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
443    #endif
444               write(dUnit,rec=irec) xy_buffer_r4
445              elseif (filePrec .eq. precFloat64) then
446               DO J=1,Ny
447                DO I=1,Nx
448                 xy_buffer_r8(I,J) = global(I,J)
449                ENDDO
450               ENDDO
451    #ifdef _BYTESWAPIO
452               call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
453    #endif
454               write(dUnit,rec=irec) xy_buffer_r8
455              else
456               write(msgbuf,'(a)')
457         &       ' MDSWRITEFIELD: illegal value for filePrec'
458               call print_error( msgbuf, mythid )
459               stop 'ABNORMAL END: S/R MDSWRITEFIELD'
460              endif
461             ENDIF
462            _END_MASTER( myThid )
463           ENDDO
464    
465    C Close data-file and create meta-file
466           _BEGIN_MASTER( myThid )
467            IF( mpiMyId .EQ. 0 ) THEN
468             close( dUnit )
469             write(metaFName(1:80),'(2a)') fName(1:IL),'.meta'
470             dimList(1,1)=Nx
471             dimList(2,1)=1
472             dimList(3,1)=Nx
473             dimList(1,2)=Ny
474             dimList(2,2)=1
475             dimList(3,2)=Ny
476             dimList(1,3)=nNz
477             dimList(2,3)=1
478             dimList(3,3)=nNz
479             ndims=3
480             if (nNz .EQ. 1) ndims=2
481             call MDSWRITEMETA( metaFName, dataFName,
482         &     filePrec, ndims, dimList, irecord, myIter, mythid )
483            ENDIF
484           _END_MASTER( myThid )
485    C To be safe, make other processes wait for I/O completion
486           _BARRIER
487    
488          elseif ( .NOT. useSingleCpuIO ) then
489          _BEGIN_MASTER( myThid )
490    #endif /* ALLOW_USE_MPI */
491    cph-usesingle)
492    
493  C Loop over all processors      C Loop over all processors    
494        do jp=1,nPy        do jp=1,nPy
# Line 361  C If we are writing to a tiled MDS file Line 513  C If we are writing to a tiled MDS file
513            fileIsOpen=.TRUE.            fileIsOpen=.TRUE.
514           endif           endif
515          if (fileIsOpen) then          if (fileIsOpen) then
516           do k=1,nNz           do k=1,Nr
517            do j=1,sNy            do j=1,sNy
518               do ii=1,sNx               do ii=1,sNx
519                  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)
520               enddo               enddo
521              iG = 0              iG = 0
522              jG = 0              jG = 0
523              irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
524             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
525              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
526               call MDS_SEG4toRS( j,bi,bj,k,nNz, r4seg, .FALSE., arr )               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
527              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
528               call MDS_SEG4toRL( j,bi,bj,k,nNz, r4seg, .FALSE., arr )               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
529              else              else
530               write(msgbuf,'(a)')               write(msgbuf,'(a)')
531       &         ' 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 538  C If we are writing to a tiled MDS file
538              write(dUnit,rec=irec) r4seg              write(dUnit,rec=irec) r4seg
539             elseif (filePrec .eq. precFloat64) then             elseif (filePrec .eq. precFloat64) then
540              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
541               call MDS_SEG8toRS( j,bi,bj,k,nNz, r8seg, .FALSE., arr )               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
542              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
543               call MDS_SEG8toRL( j,bi,bj,k,nNz, r8seg, .FALSE., arr )               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
544              else              else
545               write(msgbuf,'(a)')               write(msgbuf,'(a)')
546       &         ' 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 587  C Create meta-file for each tile if we a
587           dimList(2,3)=1           dimList(2,3)=1
588           dimList(3,3)=Nr           dimList(3,3)=Nr
589           ndims=3           ndims=3
590           if (nNz .EQ. 1) ndims=2           if (Nr .EQ. 1) ndims=2
591           call MDSWRITEMETA( metaFName, dataFName,           call MDSWRITEMETA( metaFName, dataFName,
592       &     filePrec, ndims, dimList, irecord, myIter, mythid )       &     filePrec, ndims, dimList, irecord, myIter, mythid )
593  C End of bi,bj loops  C End of bi,bj loops
# Line 445  C End of ip,jp loops Line 597  C End of ip,jp loops
597         enddo         enddo
598        enddo        enddo
599    
600          _END_MASTER( myThid )
601    
602    cph-usesingle(
603    #ifdef ALLOW_USE_MPI
604    C endif useSingleCpuIO
605          endif
606    #endif /* ALLOW_USE_MPI */
607    cph-usesingle)
608    
609    C     ------------------------------------------------------------------
610          return
611          end
612    C=======================================================================
613    
614    C=======================================================================
615          SUBROUTINE MDSREADFIELD_2D_GL(
616         I   fName,
617         I   filePrec,
618         I   arrType,
619         I   nNz,
620         O   arr_gl,
621         I   irecord,
622         I   myThid )
623    C
624    C Arguments:
625    C
626    C fName         string  base name for file to read
627    C filePrec      integer number of bits per word in file (32 or 64)
628    C arrType       char(2) declaration of "arr": either "RS" or "RL"
629    C nNz           integer size of third dimension: normally either 1 or Nr
630    C arr           RS/RL   array to read into, arr(:,:,nNz,:,:)
631    C irecord       integer record number to read
632    C myThid        integer thread identifier
633    C
634    C MDSREADFIELD first checks to see if the file "fName" exists, then
635    C if the file "fName.data" exists and finally the tiled files of the
636    C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
637    C read because it is difficult to parse files in fortran.
638    C The precision of the file is decsribed by filePrec, set either
639    C to floatPrec32 or floatPrec64. The precision or declaration of
640    C the array argument must be consistently described by the char*(2)
641    C string arrType, either "RS" or "RL". nNz allows for both 2-D and
642    C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
643    C nNz=Nr implies a 3-D model field. irecord is the record number
644    C to be read and must be >= 1. The file data is stored in
645    C arr *but* the overlaps are *not* updated. ie. An exchange must
646    C be called. This is because the routine is sometimes called from
647    C within a MASTER_THID region.
648    C
649    C Created: 03/16/99 adcroft@mit.edu
650    
651          implicit none
652    C Global variables / common blocks
653    #include "SIZE.h"
654    #include "EEPARAMS.h"
655    #include "EESUPPORT.h"
656    #include "PARAMS.h"
657    
658    C Routine arguments
659          character*(*) fName
660          integer filePrec
661          character*(2) arrType
662          integer nNz, nLocz
663          parameter (nLocz = 1)
664          _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
665          integer irecord
666          integer myThid
667    C Functions
668          integer ILNBLNK
669          integer MDS_RECLEN
670    C Local variables
671          character*(80) dataFName
672          integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
673          logical exst
674          _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
675          Real*4 r4seg(sNx)
676          Real*8 r8seg(sNx)
677          logical globalFile,fileIsOpen
678          integer length_of_rec
679          character*(max_len_mbuf) msgbuf
680    C     ------------------------------------------------------------------
681    
682    C Only do I/O if I am the master thread
683          _BEGIN_MASTER( myThid )
684    
685    C Record number must be >= 1
686          if (irecord .LT. 1) then
687           write(msgbuf,'(a,i9.8)')
688         &   ' MDSREADFIELD_GL: argument irecord = ',irecord
689           call print_message( msgbuf, standardmessageunit,
690         &                     SQUEEZE_RIGHT , mythid)
691           write(msgbuf,'(a)')
692         &   ' MDSREADFIELD_GL: Invalid value for irecord'
693           call print_error( msgbuf, mythid )
694           stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
695          endif
696    
697    C Assume nothing
698          globalFile = .FALSE.
699          fileIsOpen = .FALSE.
700          IL=ILNBLNK( fName )
701    
702    C Assign a free unit number as the I/O channel for this routine
703          call MDSFINDUNIT( dUnit, mythid )
704    
705    C Check first for global file with simple name (ie. fName)
706          dataFName = fName
707          inquire( file=dataFname, exist=exst )
708          if (exst) then
709           write(msgbuf,'(a,a)')
710         &   ' MDSREADFIELD: opening global file: ',dataFName
711           call print_message( msgbuf, standardmessageunit,
712         &                     SQUEEZE_RIGHT , mythid)
713          endif
714    
715    C If negative check for global file with MDS name (ie. fName.data)
716          if (.NOT. globalFile) then
717           write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
718           inquire( file=dataFname, exist=exst )
719           if (exst) then
720            write(msgbuf,'(a,a)')
721         &    ' MDSREADFIELD_GL: opening global file: ',dataFName
722            call print_message( msgbuf, standardmessageunit,
723         &                      SQUEEZE_RIGHT , mythid)
724            globalFile = .TRUE.
725           endif
726          endif
727    
728          if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
729    
730    C If we are reading from a global file then we open it here
731          if (globalFile) then
732           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
733           open( dUnit, file=dataFName, status='old',
734         &      access='direct', recl=length_of_rec )
735           fileIsOpen=.TRUE.
736          endif
737    
738    C Loop over all processors    
739          do jp=1,nPy
740          do ip=1,nPx
741    C Loop over all tiles
742          do bj=1,nSy
743          do bi=1,nSx
744    C If we are reading from a tiled MDS file then we open each one here
745            if (.NOT. globalFile) then
746             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
747             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
748             write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
749         &              fName(1:IL),'.',iG,'.',jG,'.data'
750             inquire( file=dataFname, exist=exst )
751    C Of course, we only open the file if the tile is "active"
752    C (This is a place-holder for the active/passive mechanism
753             if (exst) then
754              if ( debugLevel .GE. debLevA ) then
755               write(msgbuf,'(a,a)')
756         &      ' MDSREADFIELD_GL: opening file: ',dataFName
757               call print_message( msgbuf, standardmessageunit,
758         &                        SQUEEZE_RIGHT , mythid)
759              endif
760              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
761              open( dUnit, file=dataFName, status='old',
762         &        access='direct', recl=length_of_rec )
763              fileIsOpen=.TRUE.
764             else
765              fileIsOpen=.FALSE.
766              write(msgbuf,'(a,a)')
767         &      ' MDSREADFIELD_GL: filename: ',dataFName
768              call print_message( msgbuf, standardmessageunit,
769         &                        SQUEEZE_RIGHT , mythid)
770              call print_error( msgbuf, mythid )
771              write(msgbuf,'(a)')
772         &      ' MDSREADFIELD_GL: File does not exist'
773              call print_message( msgbuf, standardmessageunit,
774         &                        SQUEEZE_RIGHT , mythid)
775              call print_error( msgbuf, mythid )
776              stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
777             endif
778            endif
779    
780            if (fileIsOpen) then
781             do k=1,nLocz
782              do j=1,sNy
783               if (globalFile) then
784                iG=bi+(ip-1)*nsx
785                jG=bj+(jp-1)*nsy
786                irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
787         &             + nSx*nPx*Ny*nLocz*(irecord-1)
788               else
789                iG = 0
790                jG = 0
791                irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
792               endif
793               if (filePrec .eq. precFloat32) then
794                read(dUnit,rec=irec) r4seg
795    #ifdef _BYTESWAPIO
796                call MDS_BYTESWAPR4( sNx, r4seg )
797    #endif
798                if (arrType .eq. 'RS') then
799                 call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
800                elseif (arrType .eq. 'RL') then
801                 call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
802                else
803                 write(msgbuf,'(a)')
804         &         ' MDSREADFIELD_GL: illegal value for arrType'
805                 call print_error( msgbuf, mythid )
806                 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
807                endif
808               elseif (filePrec .eq. precFloat64) then
809                read(dUnit,rec=irec) r8seg
810    #ifdef _BYTESWAPIO
811                call MDS_BYTESWAPR8( sNx, r8seg )
812    #endif
813                if (arrType .eq. 'RS') then
814                 call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
815                elseif (arrType .eq. 'RL') then
816                 call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
817                else
818                 write(msgbuf,'(a)')
819         &         ' MDSREADFIELD_GL: illegal value for arrType'
820                 call print_error( msgbuf, mythid )
821                 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
822                endif
823               else
824                write(msgbuf,'(a)')
825         &        ' MDSREADFIELD_GL: illegal value for filePrec'
826                call print_error( msgbuf, mythid )
827                stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
828               endif
829           do ii=1,sNx
830            arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
831           enddo
832    
833    C End of j loop
834              enddo
835    C End of k loop
836             enddo
837             if (.NOT. globalFile) then
838              close( dUnit )
839              fileIsOpen = .FALSE.
840             endif
841            endif
842    C End of bi,bj loops
843           enddo
844          enddo
845    C End of ip,jp loops
846           enddo
847          enddo
848    
849    C If global file was opened then close it
850          if (fileIsOpen .AND. globalFile) then
851           close( dUnit )
852           fileIsOpen = .FALSE.
853          endif
854    
855          endif
856    c      end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
857    
858          _END_MASTER( myThid )
859    
860    C     ------------------------------------------------------------------
861          return
862          end
863    C=======================================================================
864    
865    C=======================================================================
866          SUBROUTINE MDSWRITEFIELD_2D_GL(
867         I   fName,
868         I   filePrec,
869         I   arrType,
870         I   nNz,
871         I   arr_gl,
872         I   irecord,
873         I   myIter,
874         I   myThid )
875    C
876    C Arguments:
877    C
878    C fName         string  base name for file to written
879    C filePrec      integer number of bits per word in file (32 or 64)
880    C arrType       char(2) declaration of "arr": either "RS" or "RL"
881    C nNz           integer size of third dimension: normally either 1 or Nr
882    C arr           RS/RL   array to write, arr(:,:,nNz,:,:)
883    C irecord       integer record number to read
884    C myIter        integer time step number
885    C myThid        integer thread identifier
886    C
887    C MDSWRITEFIELD creates either a file of the form "fName.data" and
888    C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
889    C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
890    C "fName.xxx.yyy.meta". A meta-file is always created.
891    C Currently, the meta-files are not read because it is difficult
892    C to parse files in fortran. We should read meta information before
893    C adding records to an existing multi-record file.
894    C The precision of the file is decsribed by filePrec, set either
895    C to floatPrec32 or floatPrec64. The precision or declaration of
896    C the array argument must be consistently described by the char*(2)
897    C string arrType, either "RS" or "RL". nNz allows for both 2-D and
898    C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
899    C nNz=Nr implies a 3-D model field. irecord is the record number
900    C to be read and must be >= 1. NOTE: It is currently assumed that
901    C the highest record number in the file was the last record written.
902    C Nor is there a consistency check between the routine arguments and file.
903    C ie. if your write record 2 after record 4 the meta information
904    C will record the number of records to be 2. This, again, is because
905    C we have read the meta information. To be fixed.
906    C
907    C Created: 03/16/99 adcroft@mit.edu
908    C
909    C Changed: 05/31/00 heimbach@mit.edu
910    C          open(dUnit, ..., status='old', ... -> status='unknown'
911    
912          implicit none
913    C Global variables / common blocks
914    #include "SIZE.h"
915    #include "EEPARAMS.h"
916    #include "EESUPPORT.h"
917    #include "PARAMS.h"
918    
919    C Routine arguments
920          character*(*) fName
921          integer filePrec
922          character*(2) arrType
923          integer nNz, nLocz
924          parameter (nLocz = 1)
925    cph(
926    cph      Real arr(*)
927          _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
928    cph)
929          integer irecord
930          integer myIter
931          integer myThid
932    C Functions
933          integer ILNBLNK
934          integer MDS_RECLEN
935    C Local variables
936          character*(80) dataFName,metaFName
937          integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
938          Real*4 r4seg(sNx)
939          Real*8 r8seg(sNx)
940          _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
941          integer dimList(3,3),ndims
942          integer length_of_rec
943          logical fileIsOpen
944          character*(max_len_mbuf) msgbuf
945    cph-usesingle(
946          integer ii,jj
947          integer x_size,y_size,iG_IO,jG_IO,npe
948          PARAMETER ( x_size = Nx )
949          PARAMETER ( y_size = Ny )
950          Real*4 xy_buffer_r4(x_size,y_size)
951          Real*8 xy_buffer_r8(x_size,y_size)
952          Real*8 global(Nx,Ny)
953    cph-usesingle)
954    
955    C     ------------------------------------------------------------------
956    
957    C Only do I/O if I am the master thread
958          _BEGIN_MASTER( myThid )
959    
960    C Record number must be >= 1
961          if (irecord .LT. 1) then
962           write(msgbuf,'(a,i9.8)')
963         &   ' MDSWRITEFIELD_GL: argument irecord = ',irecord
964           call print_message( msgbuf, standardmessageunit,
965         &                     SQUEEZE_RIGHT , mythid)
966           write(msgbuf,'(a)')
967         &   ' MDSWRITEFIELD_GL: invalid value for irecord'
968           call print_error( msgbuf, mythid )
969           stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
970          endif
971    
972    C Assume nothing
973          fileIsOpen=.FALSE.
974          IL=ILNBLNK( fName )
975    
976    C Assign a free unit number as the I/O channel for this routine
977          call MDSFINDUNIT( dUnit, mythid )
978    
979    
980    cph-usesingle(
981    #ifdef ALLOW_USE_MPI
982        _END_MASTER( myThid )        _END_MASTER( myThid )
983    C If option globalFile is desired but does not work or if
984    C globalFile is too slow, then try using single-CPU I/O.
985          if (useSingleCpuIO) then
986    
987    C Master thread of process 0, only, opens a global file
988           _BEGIN_MASTER( myThid )
989            IF( mpiMyId .EQ. 0 ) THEN
990             write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
991             length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
992             if (irecord .EQ. 1) then
993              open( dUnit, file=dataFName, status=_NEW_STATUS,
994         &        access='direct', recl=length_of_rec )
995             else
996              open( dUnit, file=dataFName, status=_OLD_STATUS,
997         &        access='direct', recl=length_of_rec )
998             endif
999            ENDIF
1000           _END_MASTER( myThid )
1001    
1002    C Gather array and write it to file, one vertical level at a time
1003           DO k=1,nLocz
1004    C Loop over all processors    
1005            do jp=1,nPy
1006            do ip=1,nPx
1007            DO bj = myByLo(myThid), myByHi(myThid)
1008             DO bi = myBxLo(myThid), myBxHi(myThid)
1009              DO J=1,sNy
1010               JJ=((jp-1)*nSy+(bj-1))*sNy+J
1011               DO I=1,sNx
1012                II=((ip-1)*nSx+(bi-1))*sNx+I
1013                global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
1014               ENDDO
1015              ENDDO
1016             ENDDO
1017            ENDDO
1018            enddo
1019            enddo
1020            _BEGIN_MASTER( myThid )
1021             IF( mpiMyId .EQ. 0 ) THEN
1022              irec=k+nLocz*(irecord-1)
1023              if (filePrec .eq. precFloat32) then
1024               DO J=1,Ny
1025                DO I=1,Nx
1026                 xy_buffer_r4(I,J) = global(I,J)
1027                ENDDO
1028               ENDDO
1029    #ifdef _BYTESWAPIO
1030               call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
1031    #endif
1032               write(dUnit,rec=irec) xy_buffer_r4
1033              elseif (filePrec .eq. precFloat64) then
1034               DO J=1,Ny
1035                DO I=1,Nx
1036                 xy_buffer_r8(I,J) = global(I,J)
1037                ENDDO
1038               ENDDO
1039    #ifdef _BYTESWAPIO
1040               call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
1041    #endif
1042               write(dUnit,rec=irec) xy_buffer_r8
1043              else
1044               write(msgbuf,'(a)')
1045         &       ' MDSWRITEFIELD: illegal value for filePrec'
1046               call print_error( msgbuf, mythid )
1047               stop 'ABNORMAL END: S/R MDSWRITEFIELD'
1048              endif
1049             ENDIF
1050            _END_MASTER( myThid )
1051           ENDDO
1052    
1053    C Close data-file and create meta-file
1054           _BEGIN_MASTER( myThid )
1055            IF( mpiMyId .EQ. 0 ) THEN
1056             close( dUnit )
1057             write(metaFName(1:80),'(2a)') fName(1:IL),'.meta'
1058             dimList(1,1)=Nx
1059             dimList(2,1)=1
1060             dimList(3,1)=Nx
1061             dimList(1,2)=Ny
1062             dimList(2,2)=1
1063             dimList(3,2)=Ny
1064             dimList(1,3)=nLocz
1065             dimList(2,3)=1
1066             dimList(3,3)=nLocz
1067             ndims=3
1068             if (nLocz .EQ. 1) ndims=2
1069             call MDSWRITEMETA( metaFName, dataFName,
1070         &     filePrec, ndims, dimList, irecord, myIter, mythid )
1071            ENDIF
1072           _END_MASTER( myThid )
1073    C To be safe, make other processes wait for I/O completion
1074           _BARRIER
1075    
1076          elseif ( .NOT. useSingleCpuIO ) then
1077          _BEGIN_MASTER( myThid )
1078    #endif /* ALLOW_USE_MPI */
1079    cph-usesingle)
1080    
1081    C Loop over all processors    
1082          do jp=1,nPy
1083          do ip=1,nPx
1084    C Loop over all tiles
1085          do bj=1,nSy
1086           do bi=1,nSx
1087    C If we are writing to a tiled MDS file then we open each one here
1088             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1089             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1090             write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
1091         &              fName(1:IL),'.',iG,'.',jG,'.data'
1092             if (irecord .EQ. 1) then
1093              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1094              open( dUnit, file=dataFName, status=_NEW_STATUS,
1095         &       access='direct', recl=length_of_rec )
1096              fileIsOpen=.TRUE.
1097             else
1098              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1099              open( dUnit, file=dataFName, status=_OLD_STATUS,
1100         &       access='direct', recl=length_of_rec )
1101              fileIsOpen=.TRUE.
1102             endif
1103            if (fileIsOpen) then
1104             do k=1,nLocz
1105              do j=1,sNy
1106                 do ii=1,sNx
1107                    arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)
1108                 enddo
1109                iG = 0
1110                jG = 0
1111                irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
1112               if (filePrec .eq. precFloat32) then
1113                if (arrType .eq. 'RS') then
1114                 call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1115                elseif (arrType .eq. 'RL') then
1116                 call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1117                else
1118                 write(msgbuf,'(a)')
1119         &         ' MDSWRITEFIELD_GL: illegal value for arrType'
1120                 call print_error( msgbuf, mythid )
1121                 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1122                endif
1123    #ifdef _BYTESWAPIO
1124                call MDS_BYTESWAPR4( sNx, r4seg )
1125  #endif  #endif
1126                write(dUnit,rec=irec) r4seg
1127               elseif (filePrec .eq. precFloat64) then
1128                if (arrType .eq. 'RS') then
1129                 call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1130                elseif (arrType .eq. 'RL') then
1131                 call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1132                else
1133                 write(msgbuf,'(a)')
1134         &         ' MDSWRITEFIELD_GL: illegal value for arrType'
1135                 call print_error( msgbuf, mythid )
1136                 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1137                endif
1138    #ifdef _BYTESWAPIO
1139                call MDS_BYTESWAPR8( sNx, r8seg )
1140    #endif
1141                write(dUnit,rec=irec) r8seg
1142               else
1143                write(msgbuf,'(a)')
1144         &        ' MDSWRITEFIELD_GL: illegal value for filePrec'
1145                call print_error( msgbuf, mythid )
1146                stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1147               endif
1148    C End of j loop
1149              enddo
1150    C End of k loop
1151             enddo
1152            else
1153             write(msgbuf,'(a)')
1154         &     ' MDSWRITEFIELD_GL: I should never get to this point'
1155             call print_error( msgbuf, mythid )
1156             stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1157            endif
1158    C If we were writing to a tiled MDS file then we close it here
1159            if (fileIsOpen) then
1160             close( dUnit )
1161             fileIsOpen = .FALSE.
1162            endif
1163    C Create meta-file for each tile if we are tiling
1164             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1165             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1166             write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
1167         &              fName(1:IL),'.',iG,'.',jG,'.meta'
1168             dimList(1,1)=Nx
1169             dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
1170             dimList(3,1)=((ip-1)*nSx+bi)*sNx
1171             dimList(1,2)=Ny
1172             dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
1173             dimList(3,2)=((jp-1)*nSy+bj)*sNy
1174             dimList(1,3)=Nr
1175             dimList(2,3)=1
1176             dimList(3,3)=Nr
1177             ndims=3
1178             if (nLocz .EQ. 1) ndims=2
1179             call MDSWRITEMETA( metaFName, dataFName,
1180         &     filePrec, ndims, dimList, irecord, myIter, mythid )
1181    C End of bi,bj loops
1182           enddo
1183          enddo
1184    C End of ip,jp loops
1185           enddo
1186          enddo
1187    
1188          _END_MASTER( myThid )
1189    
1190    #ifdef ALLOW_USE_MPI
1191    C endif useSingleCpuIO
1192          endif
1193    #endif /* ALLOW_USE_MPI */
1194    
1195  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
1196        return        return
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.8
  ViewVC Help
Powered by ViewVC 1.1.22