/[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.14 by jmc, Sun Nov 6 01:25:13 2005 UTC revision 1.21 by jmc, Sun Jan 13 22:43:53 2013 UTC
# Line 3  C $Name$ Line 3  C $Name$
3    
4  #include "MDSIO_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
12  C MDSWRITEVECTOR - write vector to direct access global or tiled MDS file  
13  C  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
 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.  
14    
 C=======================================================================  
15        SUBROUTINE MDSREADFIELD_3D_GL(        SUBROUTINE MDSREADFIELD_3D_GL(
16       I   fName,       I   fName,
17       I   filePrec,       I   filePrec,
# Line 39  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 68  C Created: 03/16/99 adcroft@mit.edu Line 52  C Created: 03/16/99 adcroft@mit.edu
52  C Global variables / common blocks  C Global variables / common blocks
53  #include "SIZE.h"  #include "SIZE.h"
54  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "EESUPPORT.h"  
55  #include "PARAMS.h"  #include "PARAMS.h"
56    
57  C Routine arguments  C Routine arguments
# Line 79  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
# Line 103  c     integer iG_IO,jG_IO,npe Line 89  c     integer iG_IO,jG_IO,npe
89        Real*8 global(Nx,Ny)        Real*8 global(Nx,Ny)
90  c     _RL    local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)  c     _RL    local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
91  cph-usesingle)  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 )
# Line 132  C Assign a free unit number as the I/O c Line 139  C Assign a free unit number as the I/O c
139        if ( useSingleCPUIO ) then        if ( useSingleCPUIO ) then
140    
141  #ifdef ALLOW_USE_MPI  #ifdef ALLOW_USE_MPI
142          IF( mpiMyId .EQ. 0 ) THEN          IF( myProcId .EQ. 0 ) THEN
143  #else  #else
144          IF ( .TRUE. ) THEN          IF ( .TRUE. ) THEN
145  #endif /* ALLOW_USE_MPI */  #endif /* ALLOW_USE_MPI */
# Line 156  C Otherwise stop program. Line 163  C Otherwise stop program.
163            open( dUnit, file=dataFName, status='old',            open( dUnit, file=dataFName, status='old',
164       &         access='direct', recl=length_of_rec )       &         access='direct', recl=length_of_rec )
165           else           else
166            write(msgbuf,'(2a)')            write(msgbuf,'(2a)')
167       &      ' MDSREADFIELD: filename: ',dataFName(1:IL)       &      ' MDSREADFIELD: filename: ',dataFName(1:IL)
168            call print_message( msgbuf, standardmessageunit,            call print_message( msgbuf, standardmessageunit,
169       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
# Line 213  C If we are reading from a global file t Line 220  C If we are reading from a global file t
220         fileIsOpen=.TRUE.         fileIsOpen=.TRUE.
221        endif        endif
222    
223  C Loop over all processors      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 229  C If we are reading from a tiled MDS fil Line 236  C If we are reading from a tiled MDS fil
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            if ( debugLevel .GE. debLevA ) then            if ( debugLevel .GE. debLevB ) then
240             write(msgbuf,'(a,a)')             write(msgbuf,'(a,a)')
241       &      ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)       &      ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)
242             call print_message( msgbuf, standardmessageunit,             call print_message( msgbuf, standardmessageunit,
# Line 274  C (This is a place-holder for the active Line 281  C (This is a place-holder for the active
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 289  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 339  c      else of if ( .not. ( globalFile . Line 350  c      else of if ( .not. ( globalFile .
350         DO k=1,nNz         DO k=1,nNz
351    
352  #ifdef ALLOW_USE_MPI  #ifdef ALLOW_USE_MPI
353           IF( mpiMyId .EQ. 0 ) THEN           IF( myProcId .EQ. 0 ) THEN
354  #else  #else
355           IF ( .TRUE. ) THEN           IF ( .TRUE. ) THEN
356  #endif /* ALLOW_USE_MPI */  #endif /* ALLOW_USE_MPI */
# Line 397  c      end of if ( .not. ( globalFile .a Line 408  c      end of if ( .not. ( globalFile .a
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 415  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 453  C          open(dUnit, ..., status='old' Line 467  C          open(dUnit, ..., status='old'
467  C Global variables / common blocks  C Global variables / common blocks
468  #include "SIZE.h"  #include "SIZE.h"
469  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "EESUPPORT.h"  
470  #include "PARAMS.h"  #include "PARAMS.h"
471    
472  C Routine arguments  C Routine arguments
# Line 468  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
# Line 477  C Local variables Line 493  C Local variables
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
# Line 493  c     integer iG_IO,jG_IO,npe Line 511  c     integer iG_IO,jG_IO,npe
511        Real*8 global(Nx,Ny)        Real*8 global(Nx,Ny)
512  #endif  #endif
513  cph-usesingle)  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 514  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 )
# Line 527  C globalFile is too slow, then try using Line 569  C globalFile is too slow, then try using
569    
570  C Master thread of process 0, only, opens a global file  C Master thread of process 0, only, opens a global file
571         _BEGIN_MASTER( myThid )         _BEGIN_MASTER( myThid )
572          IF( mpiMyId .EQ. 0 ) THEN          IF( myProcId .EQ. 0 ) THEN
573           write(dataFname,'(2a)') fName(1:IL),'.data'           write(dataFname,'(2a)') fName(1:IL),'.data'
574           length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)           length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
575           if (irecord .EQ. 1) then           if (irecord .EQ. 1) then
# Line 542  C Master thread of process 0, only, open Line 584  C Master thread of process 0, only, open
584    
585  C Gather array and write it to file, one vertical level at a time  C Gather array and write it to file, one vertical level at a time
586         DO k=1,nNz         DO k=1,nNz
587  C Loop over all processors      C Loop over all processors
588          do jp=1,nPy          do jp=1,nPy
589          do ip=1,nPx          do ip=1,nPx
590          DO bj = myByLo(myThid), myByHi(myThid)          DO bj = myByLo(myThid), myByHi(myThid)
# Line 559  C Loop over all processors Line 601  C Loop over all processors
601          enddo          enddo
602          enddo          enddo
603          _BEGIN_MASTER( myThid )          _BEGIN_MASTER( myThid )
604           IF( mpiMyId .EQ. 0 ) THEN           IF( myProcId .EQ. 0 ) THEN
605            irec=k+nNz*(irecord-1)            irec=k+nNz*(irecord-1)
606            if (filePrec .eq. precFloat32) then            if (filePrec .eq. precFloat32) then
607             DO J=1,Ny             DO J=1,Ny
# Line 593  C Loop over all processors Line 635  C Loop over all processors
635    
636  C Close data-file and create meta-file  C Close data-file and create meta-file
637         _BEGIN_MASTER( myThid )         _BEGIN_MASTER( myThid )
638          IF( mpiMyId .EQ. 0 ) THEN          IF( myProcId .EQ. 0 ) THEN
639           close( dUnit )           close( dUnit )
640           write(metaFName,'(2a)') fName(1:IL),'.meta'           write(metaFName,'(2a)') fName(1:IL),'.meta'
641           dimList(1,1)=Nx           dimList(1,1)=Nx
# Line 605  C Close data-file and create meta-file Line 647  C Close data-file and create meta-file
647           dimList(1,3)=nNz           dimList(1,3)=nNz
648           dimList(2,3)=1           dimList(2,3)=1
649           dimList(3,3)=nNz           dimList(3,3)=nNz
650           ndims=3           nDims=3
651           if (nNz .EQ. 1) ndims=2           if (nNz .EQ. 1) nDims=2
652           call MDSWRITEMETA( metaFName, dataFName,           map2gl(1) = 0
653       &     filePrec, ndims, dimList, irecord, myIter, mythid )           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          ENDIF
659         _END_MASTER( myThid )         _END_MASTER( myThid )
660  C To be safe, make other processes wait for I/O completion  C To be safe, make other processes wait for I/O completion
# Line 619  C To be safe, make other processes wait Line 665  C To be safe, make other processes wait
665  #endif /* ALLOW_USE_MPI */  #endif /* ALLOW_USE_MPI */
666  cph-usesingle)  cph-usesingle)
667    
668  C Loop over all processors      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 652  C If we are writing to a tiled MDS file Line 698  C If we are writing to a tiled MDS file
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 667  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 715  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 735  C endif useSingleCpuIO Line 789  C endif useSingleCpuIO
789  #endif /* ALLOW_USE_MPI */  #endif /* ALLOW_USE_MPI */
790  cph-usesingle)  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 752  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 781  C Created: 03/16/99 adcroft@mit.edu Line 838  C Created: 03/16/99 adcroft@mit.edu
838  C Global variables / common blocks  C Global variables / common blocks
839  #include "SIZE.h"  #include "SIZE.h"
840  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "EESUPPORT.h"  
841  #include "PARAMS.h"  #include "PARAMS.h"
842    
843  C Routine arguments  C Routine arguments
# Line 793  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
# Line 817  c     integer iG_IO,jG_IO,npe Line 876  c     integer iG_IO,jG_IO,npe
876        Real*8 global(Nx,Ny)        Real*8 global(Nx,Ny)
877  c     _RL    local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)  c     _RL    local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
878  cph-usesingle)  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 839  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 )
# Line 847  C Assign a free unit number as the I/O c Line 927  C Assign a free unit number as the I/O c
927    
928  C master thread of process 0, only, opens a global file  C master thread of process 0, only, opens a global file
929  #ifdef ALLOW_USE_MPI  #ifdef ALLOW_USE_MPI
930          IF( mpiMyId .EQ. 0 ) THEN          IF( myProcId .EQ. 0 ) THEN
931  #else  #else
932          IF ( .TRUE. ) THEN          IF ( .TRUE. ) THEN
933  #endif /* ALLOW_USE_MPI */  #endif /* ALLOW_USE_MPI */
# Line 871  C Otherwise stop program. Line 951  C Otherwise stop program.
951            open( dUnit, file=dataFName, status='old',            open( dUnit, file=dataFName, status='old',
952       &         access='direct', recl=length_of_rec )       &         access='direct', recl=length_of_rec )
953           else           else
954            write(msgbuf,'(2a)')            write(msgbuf,'(2a)')
955       &      ' MDSREADFIELD: filename: ',dataFName(1:IL)       &      ' MDSREADFIELD: filename: ',dataFName(1:IL)
956            call print_message( msgbuf, standardmessageunit,            call print_message( msgbuf, standardmessageunit,
957       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
# Line 927  C If we are reading from a global file t Line 1007  C If we are reading from a global file t
1007         fileIsOpen=.TRUE.         fileIsOpen=.TRUE.
1008        endif        endif
1009    
1010  C Loop over all processors      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 943  C If we are reading from a tiled MDS fil Line 1023  C If we are reading from a tiled MDS fil
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            if ( debugLevel .GE. debLevA ) then            if ( debugLevel .GE. debLevB ) then
1027             write(msgbuf,'(a,a)')             write(msgbuf,'(a,a)')
1028       &      ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)       &      ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)
1029             call print_message( msgbuf, standardmessageunit,             call print_message( msgbuf, standardmessageunit,
# Line 988  C (This is a place-holder for the active Line 1068  C (This is a place-holder for the active
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 1003  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 1053  c      else of if ( .not. ( globalFile . Line 1137  c      else of if ( .not. ( globalFile .
1137         DO k=1,nLocz         DO k=1,nLocz
1138    
1139  #ifdef ALLOW_USE_MPI  #ifdef ALLOW_USE_MPI
1140           IF( mpiMyId .EQ. 0 ) THEN           IF( myProcId .EQ. 0 ) THEN
1141  #else  #else
1142           IF ( .TRUE. ) THEN           IF ( .TRUE. ) THEN
1143  #endif /* ALLOW_USE_MPI */  #endif /* ALLOW_USE_MPI */
# Line 1111  c      end of if ( .not. ( globalFile .a Line 1195  c      end of if ( .not. ( globalFile .a
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 1129  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 1167  C          open(dUnit, ..., status='old' Line 1254  C          open(dUnit, ..., status='old'
1254  C Global variables / common blocks  C Global variables / common blocks
1255  #include "SIZE.h"  #include "SIZE.h"
1256  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "EESUPPORT.h"  
1257  #include "PARAMS.h"  #include "PARAMS.h"
1258    
1259  C Routine arguments  C Routine arguments
# Line 1183  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
# Line 1192  C Local variables Line 1281  C Local variables
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
# Line 1208  c     integer iG_IO,jG_IO,npe Line 1299  c     integer iG_IO,jG_IO,npe
1299        Real*8 global(Nx,Ny)        Real*8 global(Nx,Ny)
1300  #endif  #endif
1301  cph-usesingle)  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 1229  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 )
# Line 1243  C globalFile is too slow, then try using Line 1358  C globalFile is too slow, then try using
1358    
1359  C Master thread of process 0, only, opens a global file  C Master thread of process 0, only, opens a global file
1360         _BEGIN_MASTER( myThid )         _BEGIN_MASTER( myThid )
1361          IF( mpiMyId .EQ. 0 ) THEN          IF( myProcId .EQ. 0 ) THEN
1362           write(dataFname,'(2a)') fName(1:IL),'.data'           write(dataFname,'(2a)') fName(1:IL),'.data'
1363           length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)           length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
1364           if (irecord .EQ. 1) then           if (irecord .EQ. 1) then
# Line 1258  C Master thread of process 0, only, open Line 1373  C Master thread of process 0, only, open
1373    
1374  C Gather array and write it to file, one vertical level at a time  C Gather array and write it to file, one vertical level at a time
1375         DO k=1,nLocz         DO k=1,nLocz
1376  C Loop over all processors      C Loop over all processors
1377          do jp=1,nPy          do jp=1,nPy
1378          do ip=1,nPx          do ip=1,nPx
1379          DO bj = myByLo(myThid), myByHi(myThid)          DO bj = myByLo(myThid), myByHi(myThid)
# Line 1275  C Loop over all processors Line 1390  C Loop over all processors
1390          enddo          enddo
1391          enddo          enddo
1392          _BEGIN_MASTER( myThid )          _BEGIN_MASTER( myThid )
1393           IF( mpiMyId .EQ. 0 ) THEN           IF( myProcId .EQ. 0 ) THEN
1394            irec=k+nLocz*(irecord-1)            irec=k+nLocz*(irecord-1)
1395            if (filePrec .eq. precFloat32) then            if (filePrec .eq. precFloat32) then
1396             DO J=1,Ny             DO J=1,Ny
# Line 1309  C Loop over all processors Line 1424  C Loop over all processors
1424    
1425  C Close data-file and create meta-file  C Close data-file and create meta-file
1426         _BEGIN_MASTER( myThid )         _BEGIN_MASTER( myThid )
1427          IF( mpiMyId .EQ. 0 ) THEN          IF( myProcId .EQ. 0 ) THEN
1428           close( dUnit )           close( dUnit )
1429           write(metaFName,'(2a)') fName(1:IL),'.meta'           write(metaFName,'(2a)') fName(1:IL),'.meta'
1430           dimList(1,1)=Nx           dimList(1,1)=Nx
# Line 1321  C Close data-file and create meta-file Line 1436  C Close data-file and create meta-file
1436           dimList(1,3)=nLocz           dimList(1,3)=nLocz
1437           dimList(2,3)=1           dimList(2,3)=1
1438           dimList(3,3)=nLocz           dimList(3,3)=nLocz
1439           ndims=3           nDims=3
1440           if (nLocz .EQ. 1) ndims=2           if (nLocz .EQ. 1) nDims=2
1441           call MDSWRITEMETA( metaFName, dataFName,           map2gl(1) = 0
1442       &     filePrec, ndims, dimList, irecord, myIter, mythid )           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          ENDIF
1448         _END_MASTER( myThid )         _END_MASTER( myThid )
1449  C To be safe, make other processes wait for I/O completion  C To be safe, make other processes wait for I/O completion
# Line 1335  C To be safe, make other processes wait Line 1454  C To be safe, make other processes wait
1454  #endif /* ALLOW_USE_MPI */  #endif /* ALLOW_USE_MPI */
1455  cph-usesingle)  cph-usesingle)
1456    
1457  C Loop over all processors      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 1368  C If we are writing to a tiled MDS file Line 1487  C If we are writing to a tiled MDS file
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 1383  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 1431  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 1449  C endif useSingleCpuIO Line 1576  C endif useSingleCpuIO
1576        endif        endif
1577  #endif /* ALLOW_USE_MPI */  #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.14  
changed lines
  Added in v.1.21
  ViewVC Help
Powered by ViewVC 1.1.22