/[MITgcm]/MITgcm/pkg/ptracers/ptracers_read_pickup.F
ViewVC logotype

Diff of /MITgcm/pkg/ptracers/ptracers_read_pickup.F

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

revision 1.6 by jmc, Mon Dec 17 22:05:48 2007 UTC revision 1.14 by jmc, Sat Jan 2 23:42:51 2010 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3    
4    #include "GAD_OPTIONS.h"
5  #include "PTRACERS_OPTIONS.h"  #include "PTRACERS_OPTIONS.h"
6    
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
7  CBOP  CBOP
8  C     !ROUTINE: PTRACERS_READ_PICKUP  C     !ROUTINE: PTRACERS_READ_PICKUP
9    
# Line 14  C     !DESCRIPTION: Line 14  C     !DESCRIPTION:
14  C     Reads current state of passive tracers from a pickup file  C     Reads current state of passive tracers from a pickup file
15    
16  C     !USES:  C     !USES:
17    #include "PTRACERS_MOD.h"
18        IMPLICIT NONE        IMPLICIT NONE
19  #include "SIZE.h"  #include "SIZE.h"
20  #include "EEPARAMS.h"  #include "EEPARAMS.h"
21  #include "PARAMS.h"  #include "PARAMS.h"
22    #include "GAD.h"
23  #include "PTRACERS_SIZE.h"  #include "PTRACERS_SIZE.h"
24  #include "PTRACERS_PARAMS.h"  #include "PTRACERS_PARAMS.h"
25  #include "PTRACERS_RESTART.h"  #include "PTRACERS_RESTART.h"
# Line 51  C     msgBuf      :: Informational/error Line 53  C     msgBuf      :: Informational/error
53        INTEGER missFldDim, nMissing        INTEGER missFldDim, nMissing
54        INTEGER nj, ioUnit        INTEGER nj, ioUnit
55        PARAMETER( missFldDim = 2*PTRACERS_num )        PARAMETER( missFldDim = 2*PTRACERS_num )
56        CHARACTER*(MAX_LEN_MBUF) fn        CHARACTER*(MAX_LEN_FNAM) fn
57        CHARACTER*(8) fldName, missFldList(missFldDim)        CHARACTER*(8) fldName, missFldList(missFldDim)
58        CHARACTER*(MAX_LEN_MBUF) msgBuf        CHARACTER*(MAX_LEN_MBUF) msgBuf
59    #ifdef PTRACERS_ALLOW_DYN_STATE
60          INTEGER n
61    #endif
62  CEOP  CEOP
63    
64        _BARRIER  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
65    
66  #ifdef ALLOW_MNC  #ifdef ALLOW_MNC
67        IF ( PTRACERS_pickup_read_mnc ) THEN        IF ( PTRACERS_pickup_read_mnc ) THEN
# Line 79  C       Read variables from the pickup f Line 84  C       Read variables from the pickup f
84       &                     Nr, myThid )       &                     Nr, myThid )
85          ENDDO          ENDDO
86        ENDIF        ENDIF
87          IF ( useMNC .AND. PTRACERS_pickup_read_mnc ) THEN
88           DO iTracer = 1, PTRACERS_numInUse
89            IF ( PTRACERS_SOM_Advection(iTracer) ) THEN
90             WRITE(msgBuf,'(3A)')'PTRACERS_READ_PICKUP: MNC not yet coded',
91         &                       ' for SOM advection',
92         &                       ' => read bin file instead'
93             CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
94         &                       SQUEEZE_RIGHT, myThid)
95            ENDIF
96           ENDDO
97          ENDIF
98  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
99    
100        IF ( PTRACERS_pickup_read_mdsio ) THEN        IF ( PTRACERS_pickup_read_mdsio ) THEN
# Line 99  C---+----1----+----2----+----3----+----4 Line 115  C---+----1----+----2----+----3----+----4
115         _BEGIN_MASTER( myThid )         _BEGIN_MASTER( myThid )
116  c      IF ( filePrec.NE.0 .AND. filePrec.NE.prec ) THEN  c      IF ( filePrec.NE.0 .AND. filePrec.NE.prec ) THEN
117         IF ( nbFields.GE.0 .AND. filePrec.NE.prec ) THEN         IF ( nbFields.GE.0 .AND. filePrec.NE.prec ) THEN
118           WRITE(msgBuf,'(2A,I4)') 'READ_PICKUP: ',           WRITE(msgBuf,'(2A,I4)') 'PTRACERS_READ_PICKUP: ',
119       &    'pickup-file binary precision do not match !'       &    'pickup-file binary precision do not match !'
120           CALL PRINT_ERROR( msgBuf, myThid )           CALL PRINT_ERROR( msgBuf, myThid )
121           WRITE(msgBuf,'(A,2(A,I4))') 'READ_PICKUP: ',           WRITE(msgBuf,'(A,2(A,I4))') 'PTRACERS_READ_PICKUP: ',
122       &    'file prec.=', filePrec, ' but expecting prec.=', prec       &    'file prec.=', filePrec, ' but expecting prec.=', prec
123           CALL PRINT_ERROR( msgBuf, myThid )           CALL PRINT_ERROR( msgBuf, myThid )
124           STOP 'ABNORMAL END: S/R READ_PICKUP (data-prec Pb)'           STOP 'ABNORMAL END: S/R PTRACERS_READ_PICKUP (data-prec Pb)'
125         ENDIF         ENDIF
126         _END_MASTER( myThid )         _END_MASTER( myThid )
127    
# Line 113  c      IF ( filePrec.NE.0 .AND. filePrec Line 129  c      IF ( filePrec.NE.0 .AND. filePrec
129  C-      No meta-file or old meta-file without List of Fields  C-      No meta-file or old meta-file without List of Fields
130          ioUnit = errorMessageUnit          ioUnit = errorMessageUnit
131          IF ( pickupStrictlyMatch ) THEN          IF ( pickupStrictlyMatch ) THEN
132            WRITE(msgBuf,'(4A)') 'READ_PICKUP: ',            WRITE(msgBuf,'(4A)') 'PTRACERS_READ_PICKUP: ',
133       &      'no field-list found in meta-file',       &      'no field-list found in meta-file',
134       &      ' => cannot check for strick-matching'       &      ' => cannot check for strick-matching'
135            CALL PRINT_ERROR( msgBuf, myThid )            CALL PRINT_ERROR( msgBuf, myThid )
136            WRITE(msgBuf,'(4A)') 'READ_PICKUP: ',            WRITE(msgBuf,'(4A)') 'PTRACERS_READ_PICKUP: ',
137       &      'try with " pickupStrictlyMatch=.FALSE.,"',       &      'try with " pickupStrictlyMatch=.FALSE.,"',
138       &      ' in file: "data", NameList: "PARM03"'       &      ' in file: "data", NameList: "PARM03"'
139            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
140            STOP 'ABNORMAL END: S/R READ_PICKUP'            STOP 'ABNORMAL END: S/R PTRACERS_READ_PICKUP'
141          ELSE          ELSE
142            WRITE(msgBuf,'(4A)') 'WARNING >> READ_PICKUP: ',            WRITE(msgBuf,'(4A)') 'WARNING >> PTRACERS_READ_PICKUP: ',
143       &      ' no field-list found'       &      ' no field-list found'
144            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
145           IF ( nbFields.EQ.-1 ) THEN           IF ( nbFields.EQ.-1 ) THEN
# Line 137  C-      Old meta-file without List of Fi Line 153  C-      Old meta-file without List of Fi
153       &      ' try to read pickup as it used to be written'       &      ' try to read pickup as it used to be written'
154            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
155            WRITE(msgBuf,'(4A)') 'WARNING >> ',            WRITE(msgBuf,'(4A)') 'WARNING >> ',
156       &      ' until checkpoint59k (2007 Dec 18)'       &      ' until checkpoint59l (2007 Dec 17)'
157            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )            CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
158           ENDIF           ENDIF
159          ENDIF          ENDIF
# Line 230  C--    Check for missing fields: Line 246  C--    Check for missing fields:
246       U                     nMissing,       U                     nMissing,
247       I                     myIter, myThid )       I                     myIter, myThid )
248         IF ( nMissing.GT.missFldDim ) THEN         IF ( nMissing.GT.missFldDim ) THEN
249           WRITE(msgBuf,'(2A,I4)') 'READ_PICKUP: ',           WRITE(msgBuf,'(2A,I4)') 'PTRACERS_READ_PICKUP: ',
250       &     'missing fields list has been truncated to', missFldDim       &     'missing fields list has been truncated to', missFldDim
251           CALL PRINT_ERROR( msgBuf, myThid )           CALL PRINT_ERROR( msgBuf, myThid )
252           STOP 'ABNORMAL END: S/R READ_PICKUP (list-size Pb)'           STOP 'ABNORMAL END: S/R PTRACERS_READ_PICKUP (list-size Pb)'
253         ENDIF         ENDIF
254         CALL PTRACERS_CHECK_PICKUP(         CALL PTRACERS_CHECK_PICKUP(
255       I                     missFldList,       I                     missFldList,
256       I                     nMissing, nbFields,       I                     nMissing, nbFields,
257       I                     myIter, myThid )       I                     myIter, myThid )
258    
259    #ifdef PTRACERS_ALLOW_DYN_STATE
260    C--   Read pickup file with 2nd.Order moment fields
261           DO iTracer = 1, PTRACERS_numInUse
262            IF ( PTRACERS_SOM_Advection(iTracer) ) THEN
263    
264             IF (pickupSuff .EQ. ' ') THEN
265               WRITE(fn,'(3A,I10.10)') 'pickup_somTRAC',
266         &                     PTRACERS_ioLabel(iTracer),'.', myIter
267             ELSE
268               WRITE(fn,'(3A,A10)') 'pickup_somTRAC',
269         &                     PTRACERS_ioLabel(iTracer),'.', pickupSuff
270             ENDIF
271             WRITE(msgBuf,'(A,I3,A)')'PTRACERS_READ_PICKUP: iTracer = ',
272         &                      iTracer,
273         &                      ' : reading 2nd-order moments from file '
274             CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
275         &                      SQUEEZE_RIGHT, myThid)
276             CALL PRINT_MESSAGE( fn, standardMessageUnit,
277         &                      SQUEEZE_RIGHT, myThid)
278             prec = precFloat64
279    C        Read 2nd Order moments as consecutive records
280             DO n=1,nSOM
281               iRec = n
282               CALL READ_REC_3D_RL( fn, prec, Nr,
283         O               _Ptracers_som(:,:,:,:,:,n,iTracer),
284         I               iRec, myIter, myThid )
285             ENDDO
286             CALL GAD_EXCH_SOM( _Ptracers_som(:,:,:,:,:,:,iTracer),
287         &                      Nr, myThid )
288            ENDIF
289           ENDDO
290    #endif /* PTRACERS_ALLOW_DYN_STATE */
291    
292  C--   end: pickup_read_mdsio  C--   end: pickup_read_mdsio
293        ENDIF        ENDIF
294    
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.14
  ViewVC Help
Powered by ViewVC 1.1.22