/[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.5 by jmc, Mon Nov 5 18:48:04 2007 UTC revision 1.6 by jmc, Mon Dec 17 22:05:48 2007 UTC
# Line 20  C     !USES: Line 20  C     !USES:
20  #include "PARAMS.h"  #include "PARAMS.h"
21  #include "PTRACERS_SIZE.h"  #include "PTRACERS_SIZE.h"
22  #include "PTRACERS_PARAMS.h"  #include "PTRACERS_PARAMS.h"
23    #include "PTRACERS_RESTART.h"
24  #include "PTRACERS_FIELDS.h"  #include "PTRACERS_FIELDS.h"
25    
26  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
# Line 31  C     myThid            :: thread number Line 32  C     myThid            :: thread number
32  #ifdef ALLOW_PTRACERS  #ifdef ALLOW_PTRACERS
33    
34  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
35  C     iTracer           :: loop indices  C     iTracer     :: tracer index
36  C     iRec              :: record number  C     iRec        :: record number
37  C     fn                :: character buffer for creating filename  C     fn          :: character buffer for creating filename
38  C     prec              :: precision of pickup files  C     prec        :: precision of pickup files
39        INTEGER iTracer,prec,iRec  C     filePrec    :: pickup-file precision (read from meta file)
40    C     nbFields    :: number of fields in pickup file (read from meta file)
41    C     fldName     :: Name of the field to read
42    C     missFldList :: List of missing fields   (attempted to read but not found)
43    C     missFldDim  :: Dimension of missing fields list array: missFldList
44    C     nMissing    :: Number of missing fields (attempted to read but not found)
45    C     j           :: loop index
46    C     nj          :: record number
47    C     ioUnit      :: temp for writing msg unit
48    C     msgBuf      :: Informational/error message buffer
49          INTEGER iTracer, iRec, prec
50          INTEGER filePrec, nbFields
51          INTEGER missFldDim, nMissing
52          INTEGER nj, ioUnit
53          PARAMETER( missFldDim = 2*PTRACERS_num )
54        CHARACTER*(MAX_LEN_MBUF) fn        CHARACTER*(MAX_LEN_MBUF) fn
55          CHARACTER*(8) fldName, missFldList(missFldDim)
56          CHARACTER*(MAX_LEN_MBUF) msgBuf
57  CEOP  CEOP
58    
59        _BARRIER        _BARRIER
# Line 48  C       Read variables from the pickup f Line 65  C       Read variables from the pickup f
65          CALL MNC_FILE_CLOSE_ALL_MATCHING(fn, myThid)          CALL MNC_FILE_CLOSE_ALL_MATCHING(fn, myThid)
66          CALL MNC_CW_SET_UDIM(fn, 1, myThid)          CALL MNC_CW_SET_UDIM(fn, 1, myThid)
67          CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, -1, myThid)          CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, -1, myThid)
68          DO iTracer = 1,PTRACERS_numInUse          DO iTracer = 1, PTRACERS_numInUse
69            CALL MNC_CW_RL_R('D',fn,0,0, PTRACERS_names(iTracer),            CALL MNC_CW_RL_R('D',fn,0,0, PTRACERS_names(iTracer),
70       &         gpTrNm1(1-OLx,1-OLy,1,1,1,iTracer),myThid)       &         gpTrNm1(1-OLx,1-OLy,1,1,1,iTracer),myThid)
71        _EXCH_XYZ_R8(gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),myThid)            CALL EXCH_3D_RL( gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
72         &                     Nr, myThid )
73          ENDDO          ENDDO
74          CALL MNC_CW_SET_UDIM(fn, 2, myThid)          CALL MNC_CW_SET_UDIM(fn, 2, myThid)
75          DO iTracer = 1,PTRACERS_numInUse          DO iTracer = 1, PTRACERS_numInUse
76            CALL MNC_CW_RL_R('D',fn,0,0, PTRACERS_names(iTracer),            CALL MNC_CW_RL_R('D',fn,0,0, PTRACERS_names(iTracer),
77       &         pTracer(1-OLx,1-OLy,1,1,1,iTracer),myThid)       &         pTracer(1-OLx,1-OLy,1,1,1,iTracer),myThid)
78        _EXCH_XYZ_R8(pTracer(1-Olx,1-Oly,1,1,1,iTracer),myThid)            CALL EXCH_3D_RL( pTracer(1-Olx,1-Oly,1,1,1,iTracer),
79         &                     Nr, myThid )
80          ENDDO          ENDDO
81        ENDIF        ENDIF
82  #endif /*  ALLOW_MNC  */  #endif /*  ALLOW_MNC  */
83    
84        IF ( PTRACERS_pickup_read_mdsio ) THEN        IF ( PTRACERS_pickup_read_mdsio ) THEN
85    
86        IF ( pickupSuff.EQ.' ' ) THEN  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
87    
88           IF ( pickupSuff.EQ.' ' ) THEN
89          WRITE(fn,'(A,I10.10)') 'pickup_ptracers.',myIter          WRITE(fn,'(A,I10.10)') 'pickup_ptracers.',myIter
90        ELSE         ELSE
91          WRITE(fn,'(A,A10)')    'pickup_ptracers.',pickupSuff          WRITE(fn,'(A,A10)')    'pickup_ptracers.',pickupSuff
92        ENDIF         ENDIF
93        prec = precFloat64         prec = precFloat64
94    
95           CALL READ_MFLDS_SET(
96         I                      fn,
97         O                      nbFields, filePrec,
98         I                      Nr, myIter, myThid )
99           _BEGIN_MASTER( myThid )
100    c      IF ( filePrec.NE.0 .AND. filePrec.NE.prec ) THEN
101           IF ( nbFields.GE.0 .AND. filePrec.NE.prec ) THEN
102             WRITE(msgBuf,'(2A,I4)') 'READ_PICKUP: ',
103         &    'pickup-file binary precision do not match !'
104             CALL PRINT_ERROR( msgBuf, myThid )
105             WRITE(msgBuf,'(A,2(A,I4))') 'READ_PICKUP: ',
106         &    'file prec.=', filePrec, ' but expecting prec.=', prec
107             CALL PRINT_ERROR( msgBuf, myThid )
108             STOP 'ABNORMAL END: S/R READ_PICKUP (data-prec Pb)'
109           ENDIF
110           _END_MASTER( myThid )
111    
112           IF ( nbFields.LE.0 ) THEN
113    C-      No meta-file or old meta-file without List of Fields
114            ioUnit = errorMessageUnit
115            IF ( pickupStrictlyMatch ) THEN
116              WRITE(msgBuf,'(4A)') 'READ_PICKUP: ',
117         &      'no field-list found in meta-file',
118         &      ' => cannot check for strick-matching'
119              CALL PRINT_ERROR( msgBuf, myThid )
120              WRITE(msgBuf,'(4A)') 'READ_PICKUP: ',
121         &      'try with " pickupStrictlyMatch=.FALSE.,"',
122         &      ' in file: "data", NameList: "PARM03"'
123              CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
124              STOP 'ABNORMAL END: S/R READ_PICKUP'
125            ELSE
126              WRITE(msgBuf,'(4A)') 'WARNING >> READ_PICKUP: ',
127         &      ' no field-list found'
128              CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
129             IF ( nbFields.EQ.-1 ) THEN
130    C-      No meta-file
131              WRITE(msgBuf,'(4A)') 'WARNING >> ',
132         &      ' try to read pickup as currently written'
133              CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
134             ELSE
135    C-      Old meta-file without List of Fields
136              WRITE(msgBuf,'(4A)') 'WARNING >> ',
137         &      ' try to read pickup as it used to be written'
138              CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
139              WRITE(msgBuf,'(4A)') 'WARNING >> ',
140         &      ' until checkpoint59k (2007 Dec 18)'
141              CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
142             ENDIF
143            ENDIF
144           ENDIF
145    
146        IF ( usePickupBeforeC54 ) THEN  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
147    
148    C---   Very Old way to read ptracer pickup:
149           IF ( nbFields.EQ.0 .AND. usePickupBeforeC54 ) THEN
150  C       Read fields as consecutive records  C       Read fields as consecutive records
151          DO iTracer=1,PTRACERS_num          DO iTracer = 1, PTRACERS_numInUse
152            iRec = iTracer            iRec = iTracer
153            CALL READ_REC_3D_RL( fn, prec, Nr,            CALL READ_REC_3D_RL( fn, prec, Nr,
154       O         pTracer(1-Olx,1-Oly,1,1,1,iTracer),       O         pTracer(1-Olx,1-Oly,1,1,1,iTracer),
155       I         iRec, myIter, myThid )       I         iRec, myIter, myThid )
156        _EXCH_XYZ_R8(pTracer(1-Olx,1-Oly,1,1,1,iTracer),myThid)            CALL EXCH_3D_RL( pTracer(1-Olx,1-Oly,1,1,1,iTracer),
157         &                     Nr, myThid )
158          ENDDO          ENDDO
159    
160  C       Read historical tendencies as consecutive records  C       Read historical tendencies as consecutive records
161          DO iTracer=1,PTRACERS_num  c       DO iTracer = 1,PTRACERS_numInUse
162            iRec = iTracer + PTRACERS_num  c         iRec = iTracer + PTRACERS_num
163            CALL READ_REC_3D_RL( fn, prec, Nr,  c         CALL READ_REC_3D_RL( fn, prec, Nr,
164       O         gPtr(1-Olx,1-Oly,1,1,1,iTracer),  c    O         gPtr(1-Olx,1-Oly,1,1,1,iTracer),
165       I         iRec, myIter, myThid )  c    I         iRec, myIter, myThid )
166        _EXCH_XYZ_R8(gPtr(1-Olx,1-Oly,1,1,1,iTracer),myThid)  c         CALL EXCH_3D_RL( gPtr(1-Olx,1-Oly,1,1,1,iTracer),
167          ENDDO  c    &                     Nr, myThid )
168          DO iTracer=1,PTRACERS_num  c       ENDDO
169            DO iTracer = 1, PTRACERS_numInUse
170            iRec = iTracer + PTRACERS_num*2            iRec = iTracer + PTRACERS_num*2
171            CALL READ_REC_3D_RL( fn, prec, Nr,            CALL READ_REC_3D_RL( fn, prec, Nr,
172       O         gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),       O         gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
173       I         iRec, myIter, myThid )       I         iRec, myIter, myThid )
174        _EXCH_XYZ_R8(gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),myThid)            CALL EXCH_3D_RL( gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
175         &                     Nr, myThid )
176          ENDDO          ENDDO
177    
178        ELSE         ELSEIF ( nbFields.EQ.0 ) THEN
179    C---   Old way to read ptracer pickup:
180  C       Read fields & tendencies (needed for AB) as consecutive records,  C       Read fields & tendencies (needed for AB) as consecutive records,
181  C       one tracer after the other, only for tracers "InUse".  Note:  C       one tracer after the other, only for tracers "InUse".  Note:
182  C       this allow to restart from a pickup with a different number of  C       this allow to restart from a pickup with a different number of
183  C       tracers, with write_pickup dumping all of them (PTRACERS_num).  C       tracers, with write_pickup dumping all of them (PTRACERS_num).
184          DO iTracer=1,PTRACERS_numInUse          DO iTracer = 1, PTRACERS_numInUse
185            iRec = 2*iTracer -1            iRec = 2*iTracer -1
186            CALL READ_REC_3D_RL( fn, prec, Nr,            CALL READ_REC_3D_RL( fn, prec, Nr,
187       O         pTracer(1-Olx,1-Oly,1,1,1,iTracer),       O         pTracer(1-Olx,1-Oly,1,1,1,iTracer),
# Line 111  C       tracers, with write_pickup dumpi Line 190  C       tracers, with write_pickup dumpi
190            CALL READ_REC_3D_RL( fn, prec, Nr,            CALL READ_REC_3D_RL( fn, prec, Nr,
191       O         gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),       O         gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
192       I         iRec, myIter, myThid )       I         iRec, myIter, myThid )
193        _EXCH_XYZ_R8(pTracer(1-Olx,1-Oly,1,1,1,iTracer),myThid)            CALL EXCH_3D_RL( pTracer(1-Olx,1-Oly,1,1,1,iTracer),
194        _EXCH_XYZ_R8(gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),myThid)       &                     Nr, myThid )
195          ENDDO            CALL EXCH_3D_RL( gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
196         &                     Nr, myThid )
197        ENDIF          ENDDO
198    
199           ELSE
200    C---   New way to read ptracer pickup:
201            nj = 0
202            DO iTracer = 1, PTRACERS_numInUse
203    C---    read pTracer 3-D fields for restart
204              fldName = 'pTr'//PTRACERS_ioLabel(iTracer)//'   '
205              CALL READ_MFLDS_3D_RL( fldName,
206         O                     pTracer(1-Olx,1-Oly,1,1,1,iTracer),
207         &                     nj, prec, Nr, myIter, myThid )
208              CALL EXCH_3D_RL( pTracer(1-Olx,1-Oly,1,1,1,iTracer),
209         &                     Nr, myThid )
210            ENDDO
211            DO iTracer = 1, PTRACERS_numInUse
212    C---    read pTracer 3-D tendencies for AB-restart
213             IF ( PTRACERS_AdamsBashGtr(iTracer) ) THEN
214              fldName = 'gPtr'//PTRACERS_ioLabel(iTracer)//'m1'
215              CALL READ_MFLDS_3D_RL( fldName,
216         O                     gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
217         &                     nj, prec, Nr, myIter, myThid )
218              CALL EXCH_3D_RL( gpTrNm1(1-Olx,1-Oly,1,1,1,iTracer),
219         &                     Nr, myThid )
220             ENDIF
221            ENDDO
222    
223    C--    end: new way to read pickup file
224           ENDIF
225    
226    C--    Check for missing fields:
227           nMissing = missFldDim
228           CALL READ_MFLDS_CHECK(
229         O                     missFldList,
230         U                     nMissing,
231         I                     myIter, myThid )
232           IF ( nMissing.GT.missFldDim ) THEN
233             WRITE(msgBuf,'(2A,I4)') 'READ_PICKUP: ',
234         &     'missing fields list has been truncated to', missFldDim
235             CALL PRINT_ERROR( msgBuf, myThid )
236             STOP 'ABNORMAL END: S/R READ_PICKUP (list-size Pb)'
237           ENDIF
238           CALL PTRACERS_CHECK_PICKUP(
239         I                     missFldList,
240         I                     nMissing, nbFields,
241         I                     myIter, myThid )
242    
243    C--   end: pickup_read_mdsio
244        ENDIF        ENDIF
245    
246  #endif /* ALLOW_PTRACERS */  #endif /* ALLOW_PTRACERS */
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6
  ViewVC Help
Powered by ViewVC 1.1.22