/[MITgcm]/MITgcm/pkg/bbl/bbl_read_pickup.F
ViewVC logotype

Annotation of /MITgcm/pkg/bbl/bbl_read_pickup.F

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

Revision 1.1 - (hide annotations) (download)
Sat Aug 6 03:13:22 2011 UTC (12 years, 9 months ago) by dimitri
Branch: MAIN
CVS Tags: checkpoint64y, checkpoint64x, checkpoint64z, checkpoint64q, checkpoint64p, checkpoint64s, checkpoint64r, checkpoint64u, checkpoint64t, checkpoint64w, checkpoint64v, checkpoint64i, checkpoint64h, checkpoint64k, checkpoint64j, checkpoint64m, checkpoint64l, checkpoint64o, checkpoint64n, checkpoint64a, checkpoint64c, checkpoint64b, checkpoint64e, checkpoint64d, checkpoint64g, checkpoint64f, checkpoint63p, checkpoint63q, checkpoint63r, checkpoint63s, checkpoint63l, checkpoint63m, checkpoint63n, checkpoint63o, checkpoint63h, checkpoint63i, checkpoint63j, checkpoint63k, checkpoint63d, checkpoint63e, checkpoint63f, checkpoint63g, checkpoint63b, checkpoint63c, checkpoint64, checkpoint65, checkpoint66e, checkpoint66d, checkpoint66c, checkpoint66b, checkpoint66a, checkpoint65z, checkpoint65x, checkpoint65y, checkpoint65r, checkpoint65s, checkpoint65p, checkpoint65q, checkpoint65v, checkpoint65w, checkpoint65t, checkpoint65u, checkpoint65j, checkpoint65k, checkpoint65h, checkpoint65i, checkpoint65n, checkpoint65o, checkpoint65l, checkpoint65m, checkpoint65b, checkpoint65c, checkpoint65a, checkpoint65f, checkpoint65g, checkpoint65d, checkpoint65e 
adding pkg/bbl
1 dimitri 1.1 C $Header: /u/gcmpack/MITgcm_contrib/bbl/code/bbl_read_pickup.F,v 1.2 2010/12/19 05:13:36 dimitri Exp $
2     C $Name: $
3    
4     #include "BBL_OPTIONS.h"
5    
6     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7     CBOP
8     C !ROUTINE: BBL_READ_PICKUP
9    
10     C !INTERFACE:
11     SUBROUTINE BBL_READ_PICKUP( myIter, myThid )
12    
13     C !DESCRIPTION:
14     C Reads current state of BBL from a pickup file
15    
16     C !USES:
17     IMPLICIT NONE
18     #include "SIZE.h"
19     #include "EEPARAMS.h"
20     #include "PARAMS.h"
21     #include "BBL.h"
22    
23     C !INPUT PARAMETERS:
24     C myIter :: time-step number
25     C myThid :: thread number
26     INTEGER myIter
27     INTEGER myThid
28    
29     #ifdef ALLOW_BBL
30    
31     C !LOCAL VARIABLES:
32     C fn :: character buffer for creating filename
33     C fp :: precision of pickup files
34     C filePrec :: pickup-file precision (read from meta file)
35     C nbFields :: number of fields in pickup file (read from meta file)
36     C missFldList :: List of missing fields (attempted to read but not found)
37     C missFldDim :: Dimension of missing fields list array: missFldList
38     C nMissing :: Number of missing fields (attempted to read but not found)
39     C j :: loop index
40     C nj :: record number
41     C ioUnit :: temp for writing msg unit
42     C msgBuf :: Informational/error message buffer
43     INTEGER fp
44     INTEGER filePrec, nbFields
45     INTEGER missFldDim, nMissing
46     INTEGER j, nj, ioUnit
47     PARAMETER( missFldDim = 3 )
48     CHARACTER*(MAX_LEN_FNAM) fn
49     CHARACTER*(8) missFldList(missFldDim)
50     CHARACTER*(MAX_LEN_MBUF) msgBuf
51     CEOP
52    
53     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
54    
55     IF ( pickupSuff.EQ.' ' ) THEN
56     WRITE(fn,'(A,I10.10)') 'pickup_bbl.',myIter
57     ELSE
58     WRITE(fn,'(A,A10)') 'pickup_bbl.',pickupSuff
59     ENDIF
60     fp = precFloat64
61    
62     CALL READ_MFLDS_SET(
63     I fn,
64     O nbFields, filePrec,
65     I Nr, myIter, myThid )
66     _BEGIN_MASTER( myThid )
67     c IF ( filePrec.NE.0 .AND. filePrec.NE.fp ) THEN
68     IF ( nbFields.GE.0 .AND. filePrec.NE.fp ) THEN
69     WRITE(msgBuf,'(2A,I4)') 'BBL_READ_PICKUP: ',
70     & 'pickup-file binary precision do not match !'
71     CALL PRINT_ERROR( msgBuf, myThid )
72     WRITE(msgBuf,'(A,2(A,I4))') 'BBL_READ_PICKUP: ',
73     & 'file prec.=', filePrec, ' but expecting prec.=', fp
74     CALL PRINT_ERROR( msgBuf, myThid )
75     STOP 'ABNORMAL END: S/R BBL_READ_PICKUP (data-prec Pb)'
76     ENDIF
77     _END_MASTER( myThid )
78    
79     IF ( nbFields.LE.0 ) THEN
80     C- No meta-file or old meta-file without List of Fields
81     ioUnit = errorMessageUnit
82     IF ( pickupStrictlyMatch ) THEN
83     WRITE(msgBuf,'(4A)') 'BBL_READ_PICKUP: ',
84     & 'no field-list found in meta-file',
85     & ' => cannot check for strick-matching'
86     CALL PRINT_ERROR( msgBuf, myThid )
87     WRITE(msgBuf,'(4A)') 'BBL_READ_PICKUP: ',
88     & 'try with " pickupStrictlyMatch=.FALSE.,"',
89     & ' in file: "data", NameList: "PARM03"'
90     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
91     STOP 'ABNORMAL END: S/R BBL_READ_PICKUP'
92     ELSE
93     WRITE(msgBuf,'(4A)') 'WARNING >> BBL_READ_PICKUP: ',
94     & ' no field-list found'
95     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
96     IF ( nbFields.EQ.-1 ) THEN
97     C- No meta-file
98     WRITE(msgBuf,'(4A)') 'WARNING >> ',
99     & ' try to read pickup as currently written'
100     CALL PRINT_MESSAGE( msgBuf, ioUnit, SQUEEZE_RIGHT, myThid )
101     ELSE
102     WRITE(msgBuf,'(4A)') 'BBL_READ_PICKUP: ',
103     & 'no field-list found in meta-file'
104     CALL PRINT_ERROR( msgBuf, myThid )
105     STOP 'ABNORMAL END: S/R BBL_READ_PICKUP'
106     ENDIF
107     ENDIF
108     ENDIF
109    
110     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
111    
112     IF ( nbFields.EQ.0 ) THEN
113     C--- Old way to read pickup:
114    
115     ELSE
116     C--- New way to read BBL pickup:
117     nj = 0
118     C--- read BBL 2-D fields for restart
119     CALL READ_MFLDS_3D_RL( 'bblTheta', bbl_theta,
120     & nj, fp, 1 , myIter, myThid )
121     CALL READ_MFLDS_3D_RL( 'bblSalt ', bbl_salt,
122     & nj, fp, 1 , myIter, myThid )
123     CALL READ_MFLDS_3D_RL( 'bblEta ', bbl_eta,
124     & nj, fp, 1 , myIter, myThid )
125    
126     C-- end: new way to read pickup file
127     ENDIF
128    
129     C-- Check for missing fields:
130     nMissing = missFldDim
131     CALL READ_MFLDS_CHECK(
132     O missFldList,
133     U nMissing,
134     I myIter, myThid )
135     IF ( nMissing.GT.missFldDim ) THEN
136     WRITE(msgBuf,'(2A,I4)') 'BBL_READ_PICKUP: ',
137     & 'missing fields list has been truncated to', missFldDim
138     CALL PRINT_ERROR( msgBuf, myThid )
139     STOP 'ABNORMAL END: S/R BBL_READ_PICKUP (list-size Pb)'
140     ENDIF
141     IF ( nMissing.GE.1 ) THEN
142     ioUnit = errorMessageUnit
143     DO j=1,nMissing
144     WRITE(msgBuf,'(4A)') 'BBL_READ_PICKUP: ',
145     & 'cannot restart without field "',missFldList(nj),'"'
146     CALL PRINT_ERROR( msgBuf, myThid )
147     ENDDO
148     STOP 'ABNORMAL END: S/R BBL_READ_PICKUP'
149     ENDIF
150    
151     C-- Update overlap regions:
152     CALL EXCH_XY_RL( bbl_theta, myThid )
153     CALL EXCH_XY_RL( bbl_salt, myThid )
154     CALL EXCH_XY_RL( bbl_eta, myThid )
155    
156     #endif /* ALLOW_BBL */
157    
158     RETURN
159     END
  ViewVC Help
Powered by ViewVC 1.1.22