/[MITgcm]/MITgcm/model/src/read_write.F
ViewVC logotype

Diff of /MITgcm/model/src/read_write.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.2 by cnh, Mon Jun 8 21:43:01 1998 UTC revision 1.20 by cnh, Sun Feb 4 16:46:44 2001 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  #include "CPP_EEOPTIONS.h"  C $Name$
3    #include "CPP_OPTIONS.h"
 C--  File read_write.F: Routines to handle mid-level I/O interface.  
 C--   Contents  
 C--   o READ_FLD_XY_RL  - Read two-dimensional model _RL field.  
 C--   o READ_FLD_XYZ_RL - Read three-dimensional model _RL field.  
 C--   o WRITE_1D_I  - Write list of integer values  
 C--                   Uses MITgcmUV environment file format.  
 C--   o WRITE_1D_L  - Write list of logical values  
 C--                   Uses MITgcmUV environment file format.  
 C--   o WRITE_1D_R8 - Write list of real*8 values  
 C--                   Uses MITgcmUV environment file format.  
 C--   o WRITE_FLD_XY_RL  - Write two-dimensional model _RL field.  
 C--   o WRITE_FLD_XYZ_RL - Write three-dimensional model _RL field.  
 C--   o WRITE_STATE - Write out model state.  
 C--   o WRITE_CHKPT - Write out checkpoint files for restarting.  
4    
5  CStartofinterface  CStartofinterface
6        SUBROUTINE READ_CHECKPOINT ( myIter, myThid )        SUBROUTINE WRITE_1D_I( fld, lFld, index_type, head, comment )
7  C     /==========================================================\  C     /==========================================================
8  C     | SUBROUTINE READ_CHECKPOINT                               |  C     | o SUBROUTINE WRITE_1D_I                                  |
9  C     | o Controlling routine for IO to write restart file.      |  C     | Controls formatted, tabular I/O for a one-dimensional    |
10    C     | INTEGER field.                                           |
11  C     |==========================================================|  C     |==========================================================|
12  C     | Read model checkpoint files for use in restart.          |  C     | This routine produces a standard format for list         |
13    C     | one-dimensional INTEGER data in textual form. The format |
14    C     | is designed to be readily parsed by a post-processing    |
15    C     | utility.                                                 |
16  C     \==========================================================/  C     \==========================================================/
17          IMPLICIT NONE
18    
19  C     == Global variables ===  C     == Global data ==
20  #include "SIZE.h"  #include "SIZE.h"
21  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "PARAMS.h"  
 #include "DYNVARS.h"  
 #include "CG2D.h"  
   
       INTEGER  IO_ERRCOUNT  
       EXTERNAL IO_ERRCOUNT  
22    
23  C     == Routine arguments ==  C     == Routine arguments ==
24  C     myThid - Thread number for this instance of the routine.  C     fld  - Field to be printed
25  C     myIter - Iteration number  C     lFld - Number of elements in field fld.
26        INTEGER myThid  C     index_type - Type of index labelling (I=,J=,...) to use
27        INTEGER myIter  C     head - Statement start e.g. phi =
28    C     comment - Descriptive comment for field
29          INTEGER lFld
30          INTEGER fld(lFld)
31          INTEGER index_type
32          CHARACTER*(*) head
33          CHARACTER*(*) comment
34  CEndofinterface  CEndofinterface
35    
36  C     == Local variables ==  C     == Local variables ==
 C     suff - Hold suffix part of a filename  
 C     beginIOErrCount - Begin and end IO error counts  
 C     endIOErrCount  
 C     msgBuf - Error message buffer  
       CHARACTER*(MAX_LEN_FNAM) suff  
       INTEGER beginIOErrCount  
       INTEGER endIOErrCount  
37        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
       LOGICAL permCheckPoint    
38    
39  C--    Going to really do some IO. Make everyone except master thread wait.        WRITE(msgBuf,'(A,A)') head, comment
40         _BARRIER        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
41         _BEGIN_MASTER( myThid )       &    SQUEEZE_RIGHT , 1)
42          CALL PRINT_LIST_I( fld, lFld, index_type, .FALSE.,
43  C--     Set suffix for this set of data files.       &    .TRUE., standardMessageUnit )
44          WRITE(suff,'(I10.10)') myIter        WRITE(msgBuf,'(A)')   '    ;     '
45          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
46  C--     Set IO "context" for writing state       &    SQUEEZE_RIGHT , 1)
         CALL DFILE_SET_RO  
         CALL DFILE_SET_CONT_ON_ERROR  
 C       Force 64-bit IO  
         readBinaryPrec = precFloat64  
   
   
 C--     Read IO error counter  
         beginIOErrCount = IO_ERRCOUNT(myThid)  
   
 C--     Write model fields  
 C       Raw fields  
         CALL READ_FLD_XYZ_RL(   'uVel.',suff,      uVel, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(     'gU.',suff,        gU, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(  'gUNm1.',suff,     gUNm1, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(   'vVel.',suff,      vVel, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(     'gV.',suff,        gV, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(  'gVNm1.',suff,     gVNm1, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(  'theta.',suff,     theta, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(     'gT.',suff,        gT, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(  'gTNm1.',suff,     gTNm1, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(   'salt.',suff,      salt, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(     'gS.',suff,        gS, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(  'gSNm1.',suff,     gSNm1, myIter, myThid)  
         CALL READ_FLD_XY_RL ( 'cg2d_x.',suff,    cg2d_x, myIter, myThid)  
 #ifdef ALLOW_CD  
         CALL READ_FLD_XY_RL ( 'cg2d_xNM1.',suff, cg2d_xNM1, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(  'uVelD.',suff,    uVelD, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(  'vVelD.',suff,    vVelD, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(  'uNM1.', suff,     uNM1, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(  'vNM1.', suff,     vNM1, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(  'guCD.', suff,     guCD, myIter, myThid)  
         CALL READ_FLD_XYZ_RL(  'gvCD.', suff,     gvCD, myIter, myThid)  
 #endif  
   
 C--     Reread IO error counter  
         endIOErrCount = IO_ERRCOUNT(myThid)  
   
 C--     Check for IO errors  
         IF ( endIOErrCount .NE. beginIOErrCount ) THEN  
          WRITE(msgBuf,'(A)')  'S/R READ_CHECKPOINT'  
          CALL PRINT_ERROR( msgBuf, 1 )  
          WRITE(msgBuf,'(A)')  'Error reading in model checkpoint'  
          CALL PRINT_ERROR( msgBuf, 1 )  
          WRITE(msgBuf,'(A,I10)') 'Timestep ',myIter  
          CALL PRINT_ERROR( msgBuf, 1 )  
          STOP 'ABNORMAL END: S/R READ_CHECKPOINT'  
         ELSE  
          WRITE(msgBuf,'(A,I10)')  '// Model checkpoint read, timestep', myIter  
          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT, 1 )  
          WRITE(msgBuf,'(A)')  ' '  
          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT, 1 )  
         ENDIF  
   
        _END_MASTER( myThid )  
        _BARRIER  
   
 C--    Fill in edge regions  
       _EXCH_XYZ_R8(uVel  , myThid )  
       _EXCH_XYZ_R8(gu    , myThid )  
       _EXCH_XYZ_R8(guNM1 , myThid )  
       _EXCH_XYZ_R8(vVel  , myThid )  
       _EXCH_XYZ_R8(gv    , myThid )  
       _EXCH_XYZ_R8(gvNM1 , myThid )  
       _EXCH_XYZ_R8(theta , myThid )  
       _EXCH_XYZ_R8(gt    , myThid )  
       _EXCH_XYZ_R8(gtNM1 , myThid )  
       _EXCH_XYZ_R8(salt  , myThid )  
       _EXCH_XYZ_R8(gs    , myThid )  
       _EXCH_XYZ_R8(gsNM1 , myThid )  
       _EXCH_XY_R8 (cg2d_x, myThid )  
47    
       RETURN  
48        END        END
49    
50    
51  CStartofinterface  CStartofinterface
52        SUBROUTINE READ_FLD_XY_RL(  pref ,suff, fld, myIter, myThid)        SUBROUTINE WRITE_1D_L( fld, lFld, index_type, head, comment )
53  C     /==========================================================\  C     /==========================================================
54  C     | SUBROUTINE READ_FLD_XY_RL                                |  C     | o SUBROUTINE WRITE_1D_L                                  |
55  C     | o Generic two-dimensional field IO routine.              |  C     | Controls formatted, tabular I/O for a one-dimensional    |
56    C     | LOGICAL field.                                           |
57  C     |==========================================================|  C     |==========================================================|
58  C     | Call low-level routines to read a 2d model field.        |  C     | This routine produces a standard format for list         |
59  C     | Handles _RL type data ( generally _RL == REAL*8 )        |  C     | one-dimensional LOGICAL data in textual form. The format |
60    C     | is designed to be readily parsed by a post-processing    |
61    C     | utility.                                                 |
62  C     \==========================================================/  C     \==========================================================/
63          IMPLICIT NONE
64    
65  C     == Global variables ==  C     == Global data ==
66  #include "SIZE.h"  #include "SIZE.h"
 #include "PARAMS.h"  
67  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "DFILE.h"  
       
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
       EXTERNAL ILNBLNK  
       INTEGER  IO_ERRCOUNT  
       EXTERNAL IO_ERRCOUNT  
 CEndofinterface  
68    
69  C     == Routine arguments ==  C     == Routine arguments ==
70  C     pref   - File name prefix  C     fld  - Field to be printed
71  C     suff   - File name suffix  C     lFld - Number of elements in field fld.
72  C     fld    - Array to be filled  C     index_type - Type of index labelling (I=,J=,...) to use
73  C     myIter - Timestep number  C     head - Statement start e.g. phi =
74  C     myThid - Thread number calling this routine  C     comment - Descriptive comment for field
75        CHARACTER*(*) pref        INTEGER lFld
76        CHARACTER*(*) suff        LOGICAL fld(lFld)
77        _RL fld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)        INTEGER index_type
78        INTEGER myIter        CHARACTER*(*) head
79        INTEGER myThid        CHARACTER*(*) comment
80    CEndofinterface
81    
82  C     == Local variables ==  C     == Local variables ==
 C     fNamData   - Filename building strings  
 C     fNamMeta    
 C     fileHandle - Handle used to refer to an open DFILE file.  
 C     lFilled    - Used to indicate the number of elements in the  
 C                  IO buffer that have been filled.  
 C     nXP, nYp   - Processes domain extents in X and Y.  
 C     iP, jP, kP - Index in processes coordinates.  
 C     ib         - Index in IO buffer  
 C     i, j, k, bi, bj - Loop counters  
 C     s1Lo, s1Hi, s2Lo, s2Hi - Substring indices  
 C     nDims, dimList - Local and global dataset dimensions  
       CHARACTER*(MAX_LEN_FNAM) fNamData  
       CHARACTER*(MAX_LEN_FNAM) fNamMeta  
       INTEGER fileHandle  
       INTEGER lFilled    
       INTEGER nXP, nYP  
       INTEGER iP, jP, kP, ib  
       INTEGER i,j, k, bi, bj  
       INTEGER s1Lo, s1Hi, s2Lo, s2Hi  
       INTEGER nDims  
       PARAMETER ( nDims = 2 )  
       INTEGER dimList(nDims*3)  
       INTEGER beginIOErrCount, endIOErrCount  
83        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
84    
85  C--   Track IO errors        WRITE(msgBuf,'(A,A)') head, comment
86        beginIOErrCount = IO_ERRCOUNT(myThid)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
87         &    SQUEEZE_RIGHT , 1)
88  C--   Build file name        CALL PRINT_LIST_L( fld, lFld, index_type, .FALSE.,
89  C     Name has form 'prefix.suffix'       &    .TRUE., standardMessageUnit )
90  C     e.g. U.0000000100        WRITE(msgBuf,'(A)')   '    ;     '
91  C          U.0000000100        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
92        s1Lo = IFNBLNK(pref)       &    SQUEEZE_RIGHT , 1)
       s1Hi = ILNBLNK(pref)  
       s2Lo = IFNBLNK(suff)  
       s2Hi = ILNBLNK(suff)  
       WRITE( fNamData, '(A,A)' )  
      & pref(s1Lo:s1Hi),  
      & suff(s2Lo:s2Hi)  
       WRITE( fNamMeta, '(A,A)' )  
      & pref(s1Lo:s1Hi),  
      & suff(s2Lo:s2Hi)  
   
 C--   Open file  
       CALL DFILE_OPEN( fNamData, fNamMeta, myThid,  
      O                 fileHandle )  
       IF ( fileHandle .LE. 0 ) GOTO 1000  
   
 C--   Set local and global data extents  
       nXP=sNx*nSx  
       nYP=sNy*nSy  
       lFilled = sNx*nSx * sNy*nSy  
       dimList(1) = nXP*nPx  
       dimList(2) = myXGlobalLo  
       dimList(3) = myXGlobalLo+nXP-1  
       dimList(4) = nYP*nPy  
       dimList(5) = myYGlobalLo  
       dimList(6) = myYGlobalLo+nYP-1  
   
 C--   Read data  
       IF   ( readBinaryPrec .EQ. precFloat32 ) THEN  
        CALL DFILE_READ_R4( lFilled,  
      I                      fileHandle, myThid )  
       ELSE  
        CALL DFILE_READ_R8( lFilled,  
      I                      fileHandle, myThid )  
       ENDIF  
   
 C--   Copy data from IO buffer.  
 C     Also regrid it to i,j,k indexing.  
       IF   ( readBinaryPrec .EQ. precFloat32 ) THEN  
        DO bj=1,nSy  
         DO bi=1,nSx  
          DO j=1,sNy  
           DO i=1,sNx  
            iP = (bi-1)*sNx+i  
            jP = (bj-1)*sNy+j  
            ib = (jP-1)*nXP + iP  
            fld(i,j,bi,bj) = ioBuf_R4(ib)  
           ENDDO  
          ENDDO  
         ENDDO  
        ENDDO  
       ELSE  
        DO bj=1,nSy  
         DO bi=1,nSx  
          DO j=1,sNy  
           DO i=1,sNx  
            iP = (bi-1)*sNx+i  
            jP = (bj-1)*sNy+j  
            ib = (jP-1)*nXP + iP  
            fld(i,j,bi,bj) = ioBuf_R8(ib)  
           ENDDO  
          ENDDO  
         ENDDO  
        ENDDO  
       ENDIF  
   
 C--   Close file  
       CALL DFILE_CLOSE( fileHandle, myThid )  
   
 C--   Check errors  
       endIOerrCount = IO_ERRCOUNT(myThid)  
       IF ( endIOErrCount .EQ. beginIOErrCount ) THEN  
        WRITE(msgBuf,'(A,A,A,A)')  '// Read file(s) ',  
      &  pref(s1Lo:s1Hi),'*',suff(s2Lo:s2Hi)  
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT, 1 )  
       ELSE  
        WRITE(msgBuf,'(A,A,A)') 'Error reading file ',pref(s1Lo:s1Hi),suff(s2Lo:s2Hi)  
        CALL PRINT_ERROR( msgBuf, 1 )  
       ENDIF  
   
  1000 CONTINUE  
93    
       RETURN  
94        END        END
95    
96    
97  CStartofinterface  CStartofinterface
98        SUBROUTINE READ_FLD_XYZ_RL(  pref ,suff, fld, myIter, myThid)        SUBROUTINE WRITE_1D_R8( fld, lFld, index_type, head, comment )
99  C     /==========================================================\  C     /==========================================================
100  C     | SUBROUTINE READ_FLD_XYZ_RL                               |  C     | o SUBROUTINE WRITE_1D_R8                                 |
101  C     | o Generic three-dimensional field IO routine.            |  C     | Controls formatted, tabular I/O for a one-dimensional    |
102    C     | real*8 field.                                            |
103  C     |==========================================================|  C     |==========================================================|
104  C     | Call low-level routines to read a 3d model field.        |  C     | This routine produces a standard format for list         |
105  C     | Handles _RL type data ( generally _RL == REAL*8 )        |  C     | one-dimensional real*8 data in textual form. The format  |
106    C     | is designed to be readilya parsed by a post-processing   |
107    C     | utility.                                                 |
108  C     \==========================================================/  C     \==========================================================/
109          IMPLICIT NONE
110    
111  C     == Global variables ==  C     == Global data ==
112  #include "SIZE.h"  #include "SIZE.h"
 #include "PARAMS.h"  
113  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "DFILE.h"  
       
       INTEGER  IFNBLNK  
       EXTERNAL IFNBLNK  
       INTEGER  ILNBLNK  
114        EXTERNAL ILNBLNK        EXTERNAL ILNBLNK
115        INTEGER  IO_ERRCOUNT        INTEGER  ILNBLNK
       EXTERNAL IO_ERRCOUNT  
 CEndofinterface  
116    
117  C     == Routine arguments ==  C     == Routine arguments ==
118  C     pref   - File name prefix  C     fld  - Field to be printed
119  C     suff   - File name suffix  C     lFld - Number of elements in field fld.
120  C     fld    - Array to be filled  C     index_type - Type of index labelling (I=,J=,...) to use
121  C     myIter - Timestep number  C     head - Statement start e.g. phi =
122  C     myThid - Thread number calling this routine  C     comment - Descriptive comment for field
123        CHARACTER*(*) pref        INTEGER lFld
124        CHARACTER*(*) suff        Real*8 fld(lFld)
125        _RL fld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nZ,nSx,nSy)        INTEGER index_type
126        INTEGER myIter        CHARACTER*(*) head
127        INTEGER myThid        CHARACTER*(*) comment
128    CEndofinterface
129    
130  C     == Local variables ==  C     == Local variables ==
131  C     fNamData   - Filename building strings  C     ILH, ILC - Index of last balnk in head and comment
 C     fNamMeta    
 C     fileHandle - Handle used to refer to an open DFILE file.  
 C     lFilled    - Used to indicate the number of elements in the  
 C                  IO buffer that have been filled.  
 C     nXP, nYp   - Processes domain extents in X and Y.  
 C     iP, jP, kP - Index in processes coordinates.  
 C     ib         - Index in IO buffer  
 C     i, j, k, bi, bj - Loop counters  
 C     s1Lo, s1Hi, s2Lo, s2Hi - Substring indices  
 C     nDims, dimList - Local and global dataset dimensions  
       CHARACTER*(MAX_LEN_FNAM) fNamData  
       CHARACTER*(MAX_LEN_FNAM) fNamMeta  
       INTEGER fileHandle  
       INTEGER lFilled    
       INTEGER nXP, nYP  
       INTEGER iP, jP, kP, ib  
       INTEGER i,j, k, bi, bj  
       INTEGER s1Lo, s1Hi, s2Lo, s2Hi  
       INTEGER nDims  
       PARAMETER ( nDims = 3 )  
       INTEGER dimList(nDims*3)  
       INTEGER beginIOErrCount, endIOErrCount  
132        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
133          INTEGER ILH, ILC
134    
135  C--   Track IO errors        ILH=ILNBLNK(head)
136        beginIOErrCount = IO_ERRCOUNT(myThid)        ILC=ILNBLNK(comment)
137          WRITE(msgBuf,'(A,A)') head(1:ILH), comment(1:ILC)
138  C--   Build file name        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
139  C     Name has form 'prefix.suffix'       &    SQUEEZE_RIGHT , 1)
140  C     e.g. U.0000000100        CALL PRINT_LIST_R8( fld, lFld, index_type, .FALSE.,
141  C          U.0000000100       &    .TRUE., standardMessageUnit )
142        s1Lo = IFNBLNK(pref)        WRITE(msgBuf,'(A)')   '    ;     '
143        s1Hi = ILNBLNK(pref)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
144        s2Lo = IFNBLNK(suff)       &    SQUEEZE_RIGHT , 1)
       s2Hi = ILNBLNK(suff)  
       WRITE( fNamData, '(A,A)' )  
      & pref(s1Lo:s1Hi),  
      & suff(s2Lo:s2Hi)  
       WRITE( fNamMeta, '(A,A)' )  
      & pref(s1Lo:s1Hi),  
      & suff(s2Lo:s2Hi)  
   
 C--   Open file  
       CALL DFILE_OPEN( fNamData, fNamMeta, myThid,  
      O                 fileHandle )  
       IF ( fileHandle .LE. 0 ) GOTO 1000  
   
 C--   Set local and global data extents  
       nXP=sNx*nSx  
       nYP=sNy*nSy  
       lFilled = sNx*nSx * sNy*nSy * nZ  
       dimList(1) = nXP*nPx  
       dimList(2) = myXGlobalLo  
       dimList(3) = myXGlobalLo+nXP-1  
       dimList(4) = nYP*nPy  
       dimList(5) = myYGlobalLo  
       dimList(6) = myYGlobalLo+nYP-1  
       dimList(7) = nZ  
       dimList(8) = 1  
       dimList(9) = nZ  
   
 C--   Read data  
       IF   ( readBinaryPrec .EQ. precFloat32 ) THEN  
        CALL DFILE_READ_R4( lFilled,  
      I                      fileHandle, myThid )  
       ELSE  
        CALL DFILE_READ_R8( lFilled,  
      I                      fileHandle, myThid )  
       ENDIF  
   
 C--   Copy data from IO buffer.  
 C     Also regrid it to i,j,k indexing.  
       IF   ( readBinaryPrec .EQ. precFloat32 ) THEN  
        DO bj=1,nSy  
         DO bi=1,nSx  
          DO K=1,nZ  
           DO j=1,sNy  
            DO i=1,sNx  
             iP = (bi-1)*sNx+i  
             jP = (bj-1)*sNy+j  
             kP = K  
             ib = (kP-1)*nXP*nYP + (jP-1)*nXP + iP  
             fld(i,j,k,bi,bj) = ioBuf_R4(ib)  
            ENDDO  
           ENDDO  
          ENDDO  
         ENDDO  
        ENDDO  
       ELSE  
        DO bj=1,nSy  
         DO bi=1,nSx  
          DO K=1,nZ  
           DO j=1,sNy  
            DO i=1,sNx  
             iP = (bi-1)*sNx+i  
             jP = (bj-1)*sNy+j  
              kP = K  
             ib = (kP-1)*nXP*nYP + (jP-1)*nXP + iP  
             fld(i,j,k,bi,bj) = ioBuf_R8(ib)  
            ENDDO  
           ENDDO  
          ENDDO  
         ENDDO  
        ENDDO  
       ENDIF  
   
 C--   Close file  
       CALL DFILE_CLOSE( fileHandle, myThid )  
   
 C--   Check errors  
       endIOerrCount = IO_ERRCOUNT(myThid)  
       IF ( endIOErrCount .EQ. beginIOErrCount ) THEN  
        WRITE(msgBuf,'(A,A,A,A)')  '// Read file(s) ',  
      &  pref(s1Lo:s1Hi),'*',suff(s2Lo:s2Hi)  
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT, 1 )  
       ELSE  
        WRITE(msgBuf,'(A,A,A)') 'Error reading file ',pref(s1Lo:s1Hi),suff(s2Lo:s2Hi)  
        CALL PRINT_ERROR( msgBuf, 1 )  
       ENDIF  
   
  1000 CONTINUE  
145    
       RETURN  
146        END        END
147    
148    
149  CStartofinterface  CStartofinterface
150        SUBROUTINE WRITE_1D_I( fld, lFld, index_type, head, comment )        SUBROUTINE WRITE_0D_I( fld, index_type, head, comment )
151  C     /==========================================================\  C     /==========================================================
152  C     | o SUBROUTINE WRITE_1D_I                                  |  C     | o SUBROUTINE WRITE_1D_I                                  |
153  C     | Controls formatted, tabular I/O for a one-dimensional    |  C     | Controls formatted, tabular I/O for a one-dimensional    |
154  C     | INTEGER field.                                           |  C     | INTEGER field.                                           |
# Line 464  C     | one-dimensional INTEGER data in Line 158  C     | one-dimensional INTEGER data in
158  C     | is designed to be readily parsed by a post-processing    |  C     | is designed to be readily parsed by a post-processing    |
159  C     | utility.                                                 |  C     | utility.                                                 |
160  C     \==========================================================/  C     \==========================================================/
161          IMPLICIT NONE
162    
163  C     == Global data ==  C     == Global data ==
164  #include "SIZE.h"  #include "SIZE.h"
# Line 475  C     lFld - Number of elements in field Line 170  C     lFld - Number of elements in field
170  C     index_type - Type of index labelling (I=,J=,...) to use  C     index_type - Type of index labelling (I=,J=,...) to use
171  C     head - Statement start e.g. phi =  C     head - Statement start e.g. phi =
172  C     comment - Descriptive comment for field  C     comment - Descriptive comment for field
173        INTEGER lFld        INTEGER fld
       INTEGER fld(lFld)  
174        INTEGER index_type        INTEGER index_type
175        CHARACTER*(*) head        CHARACTER*(*) head
176        CHARACTER*(*) comment        CHARACTER*(*) comment
# Line 484  CEndofinterface Line 178  CEndofinterface
178    
179  C     == Local variables ==  C     == Local variables ==
180        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
181          INTEGER idummy(1)
182    
183          idummy(1) = fld
184    
185        WRITE(msgBuf,'(A,A)') head, comment        WRITE(msgBuf,'(A,A)') head, comment
186        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
187        CALL PRINT_LIST_I( fld, lFld, index_type, standardMessageUnit )       &    SQUEEZE_RIGHT , 1)
188          CALL PRINT_LIST_I( idummy, 1, index_type, .FALSE.,
189         &    .TRUE., standardMessageUnit )
190        WRITE(msgBuf,'(A)')   '    ;     '        WRITE(msgBuf,'(A)')   '    ;     '
191        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
192  C       &    SQUEEZE_RIGHT , 1)
193        RETURN  
194        END        END
195    
196    
197  CStartofinterface  CStartofinterface
198        SUBROUTINE WRITE_1D_L( fld, lFld, index_type, head, comment )        SUBROUTINE WRITE_0D_L( fld, index_type, head, comment )
199  C     /==========================================================\  C     /==========================================================
200  C     | o SUBROUTINE WRITE_1D_L                                  |  C     | o SUBROUTINE WRITE_1D_L                                  |
201  C     | Controls formatted, tabular I/O for a one-dimensional    |  C     | Controls formatted, tabular I/O for a one-dimensional    |
202  C     | LOGICAL field.                                           |  C     | LOGICAL field.                                           |
# Line 506  C     | one-dimensional LOGICAL data in Line 206  C     | one-dimensional LOGICAL data in
206  C     | is designed to be readily parsed by a post-processing    |  C     | is designed to be readily parsed by a post-processing    |
207  C     | utility.                                                 |  C     | utility.                                                 |
208  C     \==========================================================/  C     \==========================================================/
209          IMPLICIT NONE
210    
211  C     == Global data ==  C     == Global data ==
212  #include "SIZE.h"  #include "SIZE.h"
# Line 517  C     lFld - Number of elements in field Line 218  C     lFld - Number of elements in field
218  C     index_type - Type of index labelling (I=,J=,...) to use  C     index_type - Type of index labelling (I=,J=,...) to use
219  C     head - Statement start e.g. phi =  C     head - Statement start e.g. phi =
220  C     comment - Descriptive comment for field  C     comment - Descriptive comment for field
221        INTEGER lFld        LOGICAL fld
       LOGICAL fld(lFld)  
222        INTEGER index_type        INTEGER index_type
223        CHARACTER*(*) head        CHARACTER*(*) head
224        CHARACTER*(*) comment        CHARACTER*(*) comment
# Line 526  CEndofinterface Line 226  CEndofinterface
226    
227  C     == Local variables ==  C     == Local variables ==
228        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
229          LOGICAL ldummy(1)
230    
231          ldummy(1) = fld
232        WRITE(msgBuf,'(A,A)') head, comment        WRITE(msgBuf,'(A,A)') head, comment
233        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
234        CALL PRINT_LIST_L( fld, lFld, index_type, standardMessageUnit )       &    SQUEEZE_RIGHT , 1)
235          CALL PRINT_LIST_L( ldummy, 1, index_type, .FALSE.,
236         &    .TRUE., standardMessageUnit )
237        WRITE(msgBuf,'(A)')   '    ;     '        WRITE(msgBuf,'(A)')   '    ;     '
238        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
239  C       &    SQUEEZE_RIGHT , 1)
240        RETURN  
241        END        END
242    
243    
244  CStartofinterface  CStartofinterface
245        SUBROUTINE WRITE_1D_R8( fld, lFld, index_type, head, comment )        SUBROUTINE WRITE_0D_R8( fld, index_type, head, comment )
246  C     /==========================================================\  C     /==========================================================
247  C     | o SUBROUTINE WRITE_1D_R8                                 |  C     | o SUBROUTINE WRITE_1D_R8                                 |
248  C     | Controls formatted, tabular I/O for a one-dimensional    |  C     | Controls formatted, tabular I/O for a one-dimensional    |
249  C     | real*8 field.                                            |  C     | real*8 field.                                            |
# Line 548  C     | one-dimensional real*8 data in t Line 253  C     | one-dimensional real*8 data in t
253  C     | is designed to be readilya parsed by a post-processing   |  C     | is designed to be readilya parsed by a post-processing   |
254  C     | utility.                                                 |  C     | utility.                                                 |
255  C     \==========================================================/  C     \==========================================================/
256          IMPLICIT NONE
257    
258  C     == Global data ==  C     == Global data ==
259  #include "SIZE.h"  #include "SIZE.h"
# Line 559  C     lFld - Number of elements in field Line 265  C     lFld - Number of elements in field
265  C     index_type - Type of index labelling (I=,J=,...) to use  C     index_type - Type of index labelling (I=,J=,...) to use
266  C     head - Statement start e.g. phi =  C     head - Statement start e.g. phi =
267  C     comment - Descriptive comment for field  C     comment - Descriptive comment for field
268        INTEGER lFld        Real*8 fld
       Real*8 fld(lFld)  
269        INTEGER index_type        INTEGER index_type
270        CHARACTER*(*) head        CHARACTER*(*) head
271        CHARACTER*(*) comment        CHARACTER*(*) comment
# Line 568  CEndofinterface Line 273  CEndofinterface
273    
274  C     == Local variables ==  C     == Local variables ==
275        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
276          Real*8 r8dummy(1)
277    
278          r8dummy(1) = fld
279    
280        WRITE(msgBuf,'(A,A)') head, comment        WRITE(msgBuf,'(A,A)') head, comment
281        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
282        CALL PRINT_LIST_R8( fld, lFld, index_type, standardMessageUnit )       &    SQUEEZE_RIGHT , 1)
283          CALL PRINT_LIST_R8( r8dummy, 1, index_type, .FALSE.,
284         &    .TRUE., standardMessageUnit )
285        WRITE(msgBuf,'(A)')   '    ;     '        WRITE(msgBuf,'(A)')   '    ;     '
286        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT , 1)        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
287  C       &    SQUEEZE_RIGHT , 1)
288        RETURN  
289        END        END
290    
291    
292  CStartofinterface  CStartofinterface
293        SUBROUTINE WRITE_FLD_XY_RL(  pref ,suff, fld, myIter, myThid)        SUBROUTINE WRITE_XY_XLINE_RS(
294  C     /==========================================================\       I                              fld, sCoord, tCoord,
295  C     | SUBROUTINE WRITE_FLD_XY_RL                               |       I                              head, comment )
296  C     | o Generic two-dimensional field IO routine.              |  C     /==========================================================
297    C     | o SUBROUTINE WRITE_XY_XLINE_RS                           |
298    C     | Prints out X row of an XY RS field e.g. phi(:,n,:,m)     |
299  C     |==========================================================|  C     |==========================================================|
300  C     | Call low-level routines to write a model 2d model field. |  C     | This routine produces a standard format for list         |
301  C     | Handles _RL type data ( generally _RL == REAL*8 )        |  C     | one-dimensional RS data in textual form. The format      |
302    C     | is designed to be readily parsed by a post-processing    |
303    C     | utility.                                                 |
304  C     \==========================================================/  C     \==========================================================/
305          IMPLICIT NONE
306    
307  C     == Global variables ==  C     == Global data ==
308  #include "SIZE.h"  #include "SIZE.h"
 #include "PARAMS.h"  
309  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "DFILE.h"  
       
       INTEGER  IFNBLNK  
310        EXTERNAL IFNBLNK        EXTERNAL IFNBLNK
311        INTEGER  ILNBLNK        INTEGER  IFNBLNK
312        EXTERNAL ILNBLNK        EXTERNAL ILNBLNK
313        INTEGER  IO_ERRCOUNT        INTEGER  ILNBLNK
       EXTERNAL IO_ERRCOUNT  
 CEndofinterface  
314    
315  C     == Routine arguments ==  C     == Routine arguments ==
316  C     pref   - File name prefix  C     fld    - Field to be printed
317  C     suff   - File name suffix  C     sCoord - subgrid coordinate
318  C     fld    - Data to be written  C     tCoord - tile coordinate
319  C     myIter - Timestep number  C     head - Statement start e.g. phi =
320  C     myThid - Thread number calling this routine  C     comment - Descriptive comment for field
321        CHARACTER*(*) pref        _RS fld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
322        CHARACTER*(*) suff        INTEGER sCoord
323        _RL fld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)        INTEGER tCoord
324        INTEGER myIter        CHARACTER*(*) head
325        INTEGER myThid        CHARACTER*(*) comment
326    CEndofinterface
327    
328  C     == Local variables ==  C     == Local variables ==
329  C     fNamData   - Filename building strings        CHARACTER*(MAX_LEN_MBUF) msgBuf1
330  C     fNamMeta          CHARACTER*(MAX_LEN_MBUF) msgBuf2
331  C     fileHandle - Handle used to refer to an open DFILE file.        CHARACTER*10 num1, num2
332  C     lFilled    - Used to indicate the number of elements in the        REAL*8 xcoord(sNx*nSx)
333  C                  IO buffer that have been filled.        INTEGER bi, bj, i, j
334  C     nXP, nYp   - Processes domain extents in X and Y.        INTEGER IFN1, ILN1, IFN2, ILN2
335  C     iP, jP, kP - Index in processes coordinates.        
336  C     ib         - Index in IO buffer        WRITE(msgBuf1,'(A,A)') head,' = '
337  C     i, j, k, bi, bj - Loop counters        bj = tCoord
338  C     s1Lo, s1Hi, s2Lo, s2Hi - Substring indices        J  = sCoord
339  C     nDims, dimList - Local and global dataset dimensions        WRITE(num1,'(I10)') J
340        CHARACTER*(MAX_LEN_FNAM) fNamData        WRITE(num2,'(I10)') bj
341        CHARACTER*(MAX_LEN_FNAM) fNamMeta        IFN1 = IFNBLNK(num1)
342        INTEGER fileHandle        ILN1 = ILNBLNK(num1)
343        INTEGER lFilled          IFN2 = IFNBLNK(num2)
344        INTEGER nXP, nYP        ILN2 = ILNBLNK(num2)
345        INTEGER iP, jP, kP, ib  C     fld(:,J,:,bj)
346        INTEGER i,j, k, bi, bj        WRITE(msgBuf2,'(A,A,A,A,A,A,A,A,A)')
347        INTEGER s1Lo, s1Hi, s2Lo, s2Hi       & '  /* ', head,'(:,',
348        INTEGER nDims       & num1(IFN1:ILN1),',:,',
349        PARAMETER ( nDims = 2 )       & num2(IFN2:ILN2),') ',
350        INTEGER dimList(nDims*3)       & comment,' */'
351        INTEGER beginIOErrCount, endIOErrCount        DO bi=1,nSx
352        CHARACTER*(MAX_LEN_MBUF) msgBuf         DO I=1,sNx
353            xcoord(sNx*(bi-1)+I)=fld(I,J,bi,bj)
 C--   Track IO errors  
       beginIOErrCount = IO_ERRCOUNT(myThid)  
   
 C--   Build file name  
 C     Name has form 'prefix.pPID.tTID.class.suffix'  
 C     e.g. U.p0001.t0001.data.0000000100  
 C          U.p0001.t0001.meta.0000000100  
       s1Lo = IFNBLNK(pref)  
       s1Hi = ILNBLNK(pref)  
       s2Lo = IFNBLNK(suff)  
       s2Hi = ILNBLNK(suff)  
       WRITE( fNamData, '(A,A,I4.4,A,I4.4,A,A)' )  
      & pref(s1Lo:s1Hi),  
      & 'p',myProcId,'.t',myThid, '.data.',  
      & suff(s2Lo:s2Hi)  
       WRITE( fNamMeta, '(A,A,I4.4,A,I4.4,A,A)' )  
      & pref(s1Lo:s1Hi),  
      & 'p',myProcId,'.t',myThid, '.meta.',  
      & suff(s2Lo:s2Hi)  
   
 C--   Open file  
       CALL DFILE_OPEN( fNamData, fNamMeta, myThid,  
      O                 fileHandle )  
       IF ( fileHandle .LE. 0 ) GOTO 1000  
   
 C--   Copy data to IO buffer.  
 C     Also regrid it to i,j,k indexing.  
       nXP=sNx*nSx  
       nYP=sNy*nSy  
       lFilled = sNx*nSx * sNy*nSy  
       IF   ( writeBinaryPrec .EQ. precFloat32 ) THEN  
        DO bj=1,nSy  
         DO bi=1,nSx  
          DO j=1,sNy  
           DO i=1,sNx  
            iP = (bi-1)*sNx+i  
            jP = (bj-1)*sNy+j  
            ib = (jP-1)*nXP + iP  
            ioBuf_R4(ib) = fld(i,j,bi,bj)  
           ENDDO  
          ENDDO  
         ENDDO  
        ENDDO  
       ELSE  
        DO bj=1,nSy  
         DO bi=1,nSx  
          DO j=1,sNy  
           DO i=1,sNx  
            iP = (bi-1)*sNx+i  
            jP = (bj-1)*sNy+j  
            ib = (jP-1)*nXP + iP  
            ioBuf_R8(ib) = fld(i,j,bi,bj)  
           ENDDO  
          ENDDO  
         ENDDO  
354         ENDDO         ENDDO
355        ENDIF        ENDDO
356          CALL WRITE_1D_R8( xcoord, sNx*nSx, INDEX_I,msgBuf1,msgBuf2)
 C--   Set local and global data extents  
       dimList(1) = nXP*nPx  
       dimList(2) = myXGlobalLo  
       dimList(3) = myXGlobalLo+nXP-1  
       dimList(4) = nYP*nPy  
       dimList(5) = myYGlobalLo  
       dimList(6) = myYGlobalLo+nYP-1  
   
 C--   Write data  
       IF   ( writeBinaryPrec .EQ. precFloat32 ) THEN  
        CALL DFILE_WRITE_R4( lFilled,  
      I                      nDims, dimList,  
      I                      fileHandle, myIter, myThid )  
       ELSE  
        CALL DFILE_WRITE_R8( lFilled,  
      I                      nDims, dimList,  
      I                      fileHandle, myIter, myThid )  
       ENDIF  
   
 C--   Close file  
       CALL DFILE_CLOSE( fileHandle, myThid )  
   
 C--   Check errors  
       endIOerrCount = IO_ERRCOUNT(myThid)  
       IF ( endIOErrCount .EQ. beginIOErrCount ) THEN  
        WRITE(msgBuf,'(A,A,A,A)')  '// Wrote file(s) ',  
      &  pref(s1Lo:s1Hi),'*',suff(s2Lo:s2Hi)  
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT, 1 )  
       ELSE  
        WRITE(msgBuf,'(A,A,A)') 'Error writing file ',pref(s1Lo:s1Hi),suff(s2Lo:s2Hi)  
        CALL PRINT_ERROR( msgBuf, 1 )  
       ENDIF  
   
  1000 CONTINUE  
357    
358        RETURN        RETURN
359        END        END
360    
361  CStartofinterface  CStartofinterface
362        SUBROUTINE WRITE_FLD_XYZ_RL(  pref ,suff, fld, myIter, myThid)        SUBROUTINE WRITE_XY_YLINE_RS(
363  C     /==========================================================\       I                              fld, sCoord, tCoord,
364  C     | SUBROUTINE WRITE_FLD_XYZ_RL                              |       I                              head, comment )
365  C     | o Generic three-dimensional field IO routine.            |  C     /==========================================================
366    C     | o SUBROUTINE WRITE_XY_YLINE_RS                           |
367    C     | Prints out Y row of an XY RS field e.g. phi(n,:,m,:)     |
368  C     |==========================================================|  C     |==========================================================|
369  C     | Call low-level routines to write a model 3d model field. |  C     | This routine produces a standard format for list         |
370  C     | Handles _RL type data ( generally _RL == REAL*8 )        |  C     | one-dimensional RS data in textual form. The format      |
371    C     | is designed to be readily parsed by a post-processing    |
372    C     | utility.                                                 |
373  C     \==========================================================/  C     \==========================================================/
374          IMPLICIT NONE
375    
376  C     == Global variables ==  C     == Global data ==
377  #include "SIZE.h"  #include "SIZE.h"
 #include "PARAMS.h"  
378  #include "EEPARAMS.h"  #include "EEPARAMS.h"
 #include "DFILE.h"  
       
       INTEGER  IFNBLNK  
379        EXTERNAL IFNBLNK        EXTERNAL IFNBLNK
380        INTEGER  ILNBLNK        INTEGER  IFNBLNK
381        EXTERNAL ILNBLNK        EXTERNAL ILNBLNK
382        INTEGER  IO_ERRCOUNT        INTEGER  ILNBLNK
       EXTERNAL IO_ERRCOUNT  
 CEndofinterface  
   
 C     == Routine arguments ==  
 C     pref   - File name prefix  
 C     suff   - File name suffix  
 C     fld    - Data to be written  
 C     myIter - Timestep number  
 C     myThid - Thread number calling this routine  
       CHARACTER*(*) pref  
       CHARACTER*(*) suff  
       _RL fld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nz,nSx,nSy)  
       INTEGER myThid  
       INTEGER myIter  
   
 C     == Local variables ==  
 C     fNamData   - Filename building strings  
 C     fNamMeta    
 C     fileHandle - Handle used to refer to an open DFILE file.  
 C     lFilled    - Used to indicate the number of elements in the  
 C                  IO buffer that have been filled.  
 C     nXP, nYp   - Processes domain extents in X and Y.  
 C     iP, jP, kP - Index in processes coordinates.  
 C     ib         - Index in IO buffer  
 C     i, j, k, bi, bj - Loop counters  
 C     s1Lo, s1Hi, s2Lo, s2Hi - Substring indices  
 C     nDims, dimList - Local and global dataset dimensions  
       CHARACTER*(MAX_LEN_FNAM) fNamData  
       CHARACTER*(MAX_LEN_FNAM) fNamMeta  
       INTEGER fileHandle  
       INTEGER lFilled    
       INTEGER nXP, nYP  
       INTEGER iP, jP, kP, ib  
       INTEGER i,j, k, bi, bj  
       INTEGER s1Lo, s1Hi, s2Lo, s2Hi  
       INTEGER nDims  
       PARAMETER ( nDims = 3 )  
       INTEGER dimList(nDims*3)  
       INTEGER beginIOErrCount, endIOErrCount  
       CHARACTER*(MAX_LEN_MBUF) msgBuf  
   
 C--   Track IO errors  
       beginIOErrCount = IO_ERRCOUNT(myThid)  
   
 C--   Build file name  
 C     Name has form 'prefix.pPID.tTID.class.suffix'  
 C     e.g. U.p0001.t0001.data.0000000100  
 C          U.p0001.t0001.meta.0000000100  
       s1Lo = IFNBLNK(pref)  
       s1Hi = ILNBLNK(pref)  
       s2Lo = IFNBLNK(suff)  
       s2Hi = ILNBLNK(suff)  
       WRITE( fNamData, '(A,A,I4.4,A,I4.4,A,A)' )  
      & pref(s1Lo:s1Hi),  
      & 'p',myProcId,'.t',myThid, '.data.',  
      & suff(s2Lo:s2Hi)  
       WRITE( fNamMeta, '(A,A,I4.4,A,I4.4,A,A)' )  
      & pref(s1Lo:s1Hi),  
      & 'p',myProcId,'.t',myThid, '.meta.',  
      & suff(s2Lo:s2Hi)  
   
 C--   Open file  
       CALL DFILE_OPEN( fNamData, fNamMeta, myThid,  
      O                 fileHandle )  
       IF ( fileHandle .LE. 0 ) GOTO 1000  
   
 C--   Copy data to IO buffer.  
 C     Also regrid it to i,j,k indexing.  
       nXP=sNx*nSx  
       nYP=sNy*nSy  
       lFilled = sNx*nSx * sNy*nSy * Nz  
       IF   ( writeBinaryPrec .EQ. precFloat32 ) THEN  
        DO bj=1,nSy  
         DO bi=1,nSx  
          DO k=1,Nz  
           DO j=1,sNy  
            DO i=1,sNx  
             iP = (bi-1)*sNx+i  
             jP = (bj-1)*sNy+j  
             kP = k  
             ib = (kP-1)*nXP*nYP + (jP-1)*nXP + iP  
             ioBuf_R4(ib) = fld(i,j,k,bi,bj)  
            ENDDO  
           ENDDO  
          ENDDO  
         ENDDO  
        ENDDO  
       ELSE  
        DO bj=1,nSy  
         DO bi=1,nSx  
          DO k=1,Nz  
           DO j=1,sNy  
            DO i=1,sNx  
             iP = (bi-1)*sNx+i  
             jP = (bj-1)*sNy+j  
             kP = k  
             ib = (kP-1)*nXP*nYP + (jP-1)*nXP + iP  
             ioBuf_R8(ib) = fld(i,j,k,bi,bj)  
            ENDDO  
           ENDDO  
          ENDDO  
         ENDDO  
        ENDDO  
       ENDIF  
   
 C--   Set local and global data extents  
       dimList(1) = nXP*nPx  
       dimList(2) = myXGlobalLo  
       dimList(3) = myXGlobalLo+nXP-1  
       dimList(4) = nYP*nPy  
       dimList(5) = myYGlobalLo  
       dimList(6) = myYGlobalLo+nYP-1  
       dimList(7) = nZ  
       dimList(8) = 1  
       dimList(9) = nZ  
   
 C--   Write data  
       IF   ( writeBinaryPrec .EQ. precFloat32 ) THEN  
        CALL DFILE_WRITE_R4( lFilled,  
      I                      nDims, dimList,  
      I                      fileHandle, myIter, myThid )  
       ELSE  
        CALL DFILE_WRITE_R8( lFilled,  
      I                      nDims, dimList,  
      I                      fileHandle, myIter, myThid )  
       ENDIF  
   
 C--   Close file  
       CALL DFILE_CLOSE( fileHandle, myThid )  
   
 C--   Check errors  
       endIOerrCount = IO_ERRCOUNT(myThid)  
       IF ( endIOErrCount .EQ. beginIOErrCount ) THEN  
        WRITE(msgBuf,'(A,A,A,A)')  '// Wrote file(s) ',  
      &  pref(s1Lo:s1Hi),'*',suff(s2Lo:s2Hi)  
        CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT, 1 )  
       ELSE  
        WRITE(msgBuf,'(A,A,A)') 'Error writing file ',pref(s1Lo:s1Hi),suff(s2Lo:s2Hi)  
        CALL PRINT_ERROR( msgBuf, 1 )  
       ENDIF  
   
  1000 CONTINUE  
   
       RETURN  
       END  
   
 CStartofinterface  
       SUBROUTINE WRITE_CHECKPOINT ( modelEnd, myCurrentTime, myIter, myThid )  
 C     /==========================================================\  
 C     | SUBROUTINE WRITE_CHKPT                                   |  
 C     | o Controlling routine for IO to write restart file.      |  
 C     |==========================================================|  
 C     | Write model checkpoint files for use in restart.         |  
 C     | This routine writes both "rolling-checkpoint" files      |  
 C     | and permanent checkpoint files. A rolling checkpoint     |  
 C     | works through a circular list of suffices. Generally the |  
 C     | circular list has two entries so that a rolling          |  
 C     | checkpoint will overwrite the last rolling checkpoint    |  
 C     | but one. This is useful for running long jobs without    |  
 C     | filling too much disk space.                             |  
 C     |  In a permanent checkpoint data is written suffixed by   |  
 C     | the current timestep number. This sort of checkpoint can |  
 C     | be used to provided a snap-shot from which the model     |  
 C     | can be rerun.                                            |  
 C     \==========================================================/  
   
 C     == Global variables ===  
 #include "SIZE.h"  
 #include "EEPARAMS.h"  
 #include "PARAMS.h"  
 #include "DYNVARS.h"  
 #include "CG2D.h"  
   
       LOGICAL  DIFFERENT_MULTIPLE  
       EXTERNAL DIFFERENT_MULTIPLE  
       INTEGER  IO_ERRCOUNT  
       EXTERNAL IO_ERRCOUNT  
   
 C     == Routine arguments ==  
 C     modelEnd    - Checkpoint call at end of model run.  
 C     myThid - Thread number for this instance of the routine.  
 C     myIter - Iteration number  
 C     myCurrentTime - Current time of simulation ( s )  
       LOGICAL modelEnd      
       INTEGER myThid  
       INTEGER myIter  
       REAL    myCurrentTime  
 CEndofinterface  
   
 C     == Local variables ==  
 C     suff - Hold suffix part of a filename  
 C     beginIOErrCount - Begin and end IO error counts  
 C     endIOErrCount  
 C     msgBuf - Error message buffer  
 C     permCheckPoint - Flag indicating whether a permanent checkpoint will  
 C                      be written.  
       CHARACTER*(MAX_LEN_FNAM) suff  
       INTEGER beginIOErrCount  
       INTEGER endIOErrCount  
       CHARACTER*(MAX_LEN_MBUF) msgBuf  
       LOGICAL permCheckPoint    
   
       permCheckPoint = .FALSE.  
       permCheckPoint=  
      & DIFFERENT_MULTIPLE(pChkptFreq,myCurrentTime,myCurrentTime-deltaTClock)  
   
       IF (  
      &    (.NOT. modelEnd .AND. (  
      &     permCheckPoint  
      &     .OR.  
      &     DIFFERENT_MULTIPLE(chkptFreq,myCurrentTime,myCurrentTime-deltaTClock)  
      &     )  
      &    )  
      &     .OR.  
      &    (  
      &     modelEnd  
      &     .AND. .NOT.  
      &     permCheckPoint  
      &     .AND. .NOT.  
      &     DIFFERENT_MULTIPLE(chkptFreq,myCurrentTime,myCurrentTime-deltaTClock)  
      &    )  
      & ) THEN  
   
 C--    Going to really do some IO. Make everyone except master thread wait.  
        _BARRIER  
        _BEGIN_MASTER( myThid )  
   
 C--     Set suffix for this set of data files.  
         suff = checkPtSuff(nCheckLev)  
         IF ( permCheckPoint ) THEN  
          WRITE(suff,'(I10.10)') myIter  
         ENDIF  
   
 C--     Set IO "context" for writing state  
         CALL DFILE_SET_RW  
         CALL DFILE_SET_CONT_ON_ERROR  
 C       Force 64-bit IO  
         writeBinaryPrec = precFloat64  
   
   
 C--     Read IO error counter  
         beginIOErrCount = IO_ERRCOUNT(myThid)  
   
 C--     Write model fields  
 C       Raw fields  
         CALL WRITE_FLD_XYZ_RL(   'uVel.',suff,      uVel, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(     'gU.',suff,        gU, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'gUNm1.',suff,     gUNm1, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(   'vVel.',suff,      vVel, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(     'gV.',suff,        gV, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'gVNm1.',suff,     gVNm1, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'theta.',suff,     theta, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(     'gT.',suff,        gT, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'gTNm1.',suff,     gTNm1, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(   'salt.',suff,      salt, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(     'gS.',suff,        gS, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'gSNm1.',suff,     gSNm1, myIter, myThid)  
         CALL WRITE_FLD_XY_RL ( 'cg2d_x.',suff,    cg2d_x, myIter, myThid)  
 #ifdef ALLOW_CD  
         CALL WRITE_FLD_XY_RL ( 'cg2d_xNM1.',suff, cg2d_xNM1, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'uVelD.',suff,    uVelD, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'vVelD.',suff,    vVelD, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'uNM1.', suff,     uNM1, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'vNM1.', suff,     vNM1, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'guCD.', suff,     guCD, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'gvCD.', suff,     gvCD, myIter, myThid)  
 #endif  
   
   
 C--     Reread IO error counter  
         endIOErrCount = IO_ERRCOUNT(myThid)  
   
 C--     Check for IO errors  
         IF ( endIOErrCount .NE. beginIOErrCount ) THEN  
          WRITE(msgBuf,'(A)')  'S/R WRITE_CHECKPOINT'  
          CALL PRINT_ERROR( msgBuf, 1 )  
          WRITE(msgBuf,'(A)')  'Error writing out model checkpoint'  
          CALL PRINT_ERROR( msgBuf, 1 )  
          WRITE(msgBuf,'(A,I10)') 'Timestep ',myIter  
          CALL PRINT_ERROR( msgBuf, 1 )  
         ELSE  
          WRITE(msgBuf,'(A,I10)')  '// Model checkpoint written, timestep', myIter  
          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT, 1 )  
          WRITE(msgBuf,'(A)')  ' '  
          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT, 1 )  
 C        Wrote OK so step forward to use next checkpoint in loop.  
          IF ( .NOT. permCheckPoint ) THEN  
           nCheckLev = MOD(nCheckLev, maxNoChkptLev)+1  
          ENDIF  
         ENDIF  
   
        _END_MASTER( myThid )  
        _BARRIER  
   
       ENDIF  
   
       RETURN  
       END  
   
 CStartofinterface  
       SUBROUTINE WRITE_STATE ( myCurrentTime, myIter, myThid )  
 C     /==========================================================\  
 C     | SUBROUTINE WRITE_STATE                                   |  
 C     | o Controlling routine for IO to dump model state.        |  
 C     |==========================================================|  
 C     | Write model state files for post-processing. This file   |  
 C     | includes code for diagnosing W and RHO for output.       |  
 C     \==========================================================/  
   
 C     == Global variables ===  
 #include "SIZE.h"  
 #include "EEPARAMS.h"  
 #include "PARAMS.h"  
 #include "DYNVARS.h"  
 #include "CG2D.h"  
   
       LOGICAL  DIFFERENT_MULTIPLE  
       EXTERNAL DIFFERENT_MULTIPLE  
       INTEGER  IO_ERRCOUNT  
       EXTERNAL IO_ERRCOUNT  
383    
384  C     == Routine arguments ==  C     == Routine arguments ==
385  C     myThid - Thread number for this instance of the routine.  C     fld    - Field to be printed
386  C     myIter - Iteration number  C     sCoord - subgrid coordinate
387  C     myCurrentTime - Current time of simulation ( s )  C     tCoord - tile coordinate
388        INTEGER myThid  C     head - Statement start e.g. phi =
389        INTEGER myIter  C     comment - Descriptive comment for field
390        REAL    myCurrentTime        _RS fld(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
391          INTEGER sCoord
392          INTEGER tCoord
393          CHARACTER*(*) head
394          CHARACTER*(*) comment
395  CEndofinterface  CEndofinterface
396    
397  C     == Local variables ==  C     == Local variables ==
398  C     suff - Hold suffix part of a filename        CHARACTER*(MAX_LEN_MBUF) msgBuf1
399  C     beginIOErrCount - Begin and end IO error counts        CHARACTER*(MAX_LEN_MBUF) msgBuf2
400  C     endIOErrCount        REAL*8 ycoord(sNy*nSy)
401  C     msgBuf - Error message buffer        INTEGER bi, bj, i, j
402        CHARACTER*(MAX_LEN_FNAM) suff        CHARACTER*10 num1, num2
403        INTEGER beginIOErrCount        INTEGER IFN1, ILN1, IFN2, ILN2
404        INTEGER endIOErrCount        
405        CHARACTER*(MAX_LEN_MBUF) msgBuf        WRITE(msgBuf1,'(A,A)') head,' = '
406          bi = tCoord
407        IF ( .NOT.        I  = sCoord
408       &  DIFFERENT_MULTIPLE(dumpFreq,myCurrentTime,myCurrentTime-deltaTClock)        WRITE(num1,'(I10)') I
409       & ) RETURN        WRITE(num2,'(I10)') bi
410          IFN1 = IFNBLNK(num1)
411  C--    Going to really do some IO. Make everyone except master thread wait.        ILN1 = ILNBLNK(num1)
412         _BARRIER        IFN2 = IFNBLNK(num2)
413         _BEGIN_MASTER( myThid )        ILN2 = ILNBLNK(num2)
414    C     fld(I,:,bi,:)
415  C--     Set suffix for this set of data files.        WRITE(msgBuf2,'(A,A,A,A,A,A,A,A,A)')
416          WRITE(suff,'(I10.10)') myIter       & '  /* ',head,'(',
417         & num1(IFN1:ILN1),',:,',
418  C--     Set IO "context" for writing state       & num2(IFN2:ILN2),',:) ',
419          CALL DFILE_SET_RW       & comment,' */'
420          CALL DFILE_SET_CONT_ON_ERROR        DO bj=1,nSy
421          writeBinaryPrec = writeStatePrec         DO J=1,sNy
422            ycoord(sNy*(bj-1)+J)=fld(I,J,bi,bj)
423  C--     Read IO error counter         ENDDO
424          beginIOErrCount = IO_ERRCOUNT(myThid)        ENDDO
425          CALL WRITE_1D_R8( ycoord, sNy*nSy, INDEX_J,msgBuf1,msgBuf2)
 C--     Write model fields  
 C       Raw fields  
         CALL WRITE_FLD_XYZ_RL(  'U.',suff,      uVel, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'V.',suff,      vVel, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'T.',suff,      theta, myIter, myThid)  
         CALL WRITE_FLD_XYZ_RL(  'S.',suff,      salt, myIter, myThid)  
         CALL WRITE_FLD_XY_RL (  'H.',suff,    cg2d_x, myIter, myThid)  
 C       Hmmm.... what to do atbout these huh  
 C       need to calculate them but remember we are already within a  
 C       _MASTER section. So we can not use multithreaded code.  
 C       We can still code as blocked but the block loop will be  
 C       bj=1,nSy and bi=1,nSx.  
 C       CALL WRITE_FLD_XYZ_RL(   'W.',suff,   arr3d  , myIter, myThid)  
 C       CALL WRITE_FLD_XYZ_RL( 'RHO.',suff,   arr3d  , myIter, myThid)  
 C       CALL WRITE_FLD_XYZ_RL('RHOP.',suff,   arr3d  , myIter, myThid)  
 C       CALL WRITE_FLD_XYZ_RL(  'PH.',suff,   arr3d  , myIter, myThid)  
   
 C--     Reread IO error counter  
         endIOErrCount = IO_ERRCOUNT(myThid)  
   
 C--     Check for IO errors  
         IF ( endIOErrCount .NE. beginIOErrCount ) THEN  
          WRITE(msgBuf,'(A)')  'S/R WRITE_STATE'  
          CALL PRINT_ERROR( msgBuf, 1 )  
          WRITE(msgBuf,'(A)')  'Error writing out model state'  
          CALL PRINT_ERROR( msgBuf, 1 )  
          WRITE(msgBuf,'(A,I10)') 'Timestep ',myIter  
          CALL PRINT_ERROR( msgBuf, 1 )  
         ELSE  
          WRITE(msgBuf,'(A,I10)')  '// Model state written, timestep', myIter  
          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT, 1 )  
          WRITE(msgBuf,'(A)')  ' '  
          CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, SQUEEZE_RIGHT, 1 )  
         ENDIF  
   
        _END_MASTER( myThid )  
        _BARRIER  
426    
427        RETURN        RETURN
428        END        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.20
  ViewVC Help
Powered by ViewVC 1.1.22