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

Contents of /MITgcm/model/src/write_pickup.F

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


Revision 1.20 - (show annotations) (download)
Sat Mar 25 16:03:10 2017 UTC (7 years, 2 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint66g, checkpoint66f, checkpoint66o, checkpoint66n, checkpoint66m, checkpoint66l, checkpoint66k, checkpoint66j, checkpoint66i, checkpoint66h, HEAD
Changes since 1.19: +2 -2 lines
fix typo in previous modif (strangely, was only causing problems with old
 pgi-f77 compiler)

1 C $Header: /u/gcmpack/MITgcm/model/src/write_pickup.F,v 1.19 2017/03/24 23:26:10 jmc Exp $
2 C $Name: $
3
4 #include "PACKAGES_CONFIG.h"
5 #include "CPP_OPTIONS.h"
6
7 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
8 CBOP
9 C !ROUTINE: WRITE_PICKUP
10 C !INTERFACE:
11 SUBROUTINE WRITE_PICKUP(
12 I permPickup, suffix,
13 I myTime, myIter, myThid )
14
15 C !DESCRIPTION:
16 C Write the main-model pickup-file and do it NOW.
17 C It writes both "rolling-pickup" files (ckptA,ckptB) and
18 C permanent pickup files (with iteration number in the file name).
19 C It calls routines from other packages (\textit{eg.} rw and mnc)
20 C to do the per-variable writes.
21
22 C !USES:
23 IMPLICIT NONE
24 #include "SIZE.h"
25 #include "EEPARAMS.h"
26 #include "PARAMS.h"
27 #include "RESTART.h"
28 #include "DYNVARS.h"
29 #include "SURFACE.h"
30 #include "FFIELDS.h"
31 #ifdef ALLOW_GENERIC_ADVDIFF
32 # include "GAD.h"
33 #endif
34 #ifdef ALLOW_NONHYDROSTATIC
35 # include "NH_VARS.h"
36 #endif
37 #ifdef ALLOW_MNC
38 # include "MNC_PARAMS.h"
39 #endif
40 #if defined(ALLOW_EDDYPSI) && defined(ALLOW_GMREDI)
41 # include "GMREDI.h"
42 #endif
43
44 C !INPUT PARAMETERS:
45 C permPickup :: Is or is not a permanent pickup.
46 C suffix :: pickup-name suffix
47 C myTime :: Current time of simulation ( s )
48 C myIter :: Iteration number
49 C myThid :: Thread number for this instance of the routine.
50 LOGICAL permPickup
51 CHARACTER*(*) suffix
52 _RL myTime
53 INTEGER myIter
54 INTEGER myThid
55 CEOP
56
57 C !LOCAL VARIABLES:
58 C fp :: pickup-file precision
59 C glf :: local flag for "globalFiles"
60 C fn :: Temp. for building file name.
61 C nWrFlds :: number of fields being written
62 C n3D :: number of 3-D fields being written
63 C listDim :: dimension of "wrFldList" local array
64 C wrFldList :: list of written fields
65 C m1,m2 :: 6.th dim index (AB-3) corresponding to time-step N-1 & N-2
66 C j :: loop index / field number
67 C nj :: record number
68 C msgBuf :: Informational/error message buffer
69 INTEGER fp
70 LOGICAL glf
71 _RL timList(1)
72 CHARACTER*(MAX_LEN_FNAM) fn
73 INTEGER listDim, nWrFlds, n3D
74 PARAMETER( listDim = 20 )
75 CHARACTER*(8) wrFldList(listDim)
76 #ifdef ALLOW_ADAMSBASHFORTH_3
77 INTEGER m1, m2
78 #endif
79 INTEGER j, nj
80 CHARACTER*(MAX_LEN_MBUF) msgBuf
81 #ifndef ALLOW_GENERIC_ADVDIFF
82 LOGICAL AdamsBashforthGt
83 LOGICAL AdamsBashforthGs
84 LOGICAL AdamsBashforth_T
85 LOGICAL AdamsBashforth_S
86 PARAMETER ( AdamsBashforthGt = .FALSE. ,
87 & AdamsBashforthGs = .FALSE. ,
88 & AdamsBashforth_T = .FALSE. ,
89 & AdamsBashforth_S = .FALSE. )
90 #endif
91
92 C- Initialise:
93 DO j=1,listDim
94 wrFldList(j) = ' '
95 ENDDO
96
97 C Write model fields
98
99 C Going to really do some IO. Make everyone except master thread wait.
100 C this is done within IO routines => no longer needed
101 c _BARRIER
102
103 IF (pickup_write_mdsio) THEN
104
105 WRITE(fn,'(A,A)') 'pickup.', suffix
106 fp = precFloat64
107 j = 0
108 C record number < 0 : a hack not to write meta files now:
109
110 C--- write State 3-D fields for restart
111 j = j + 1
112 CALL WRITE_REC_3D_RL( fn, fp, Nr, uVel, -j, myIter, myThid )
113 IF (j.LE.listDim) wrFldList(j) = 'Uvel '
114 j = j + 1
115 CALL WRITE_REC_3D_RL( fn, fp, Nr, vVel, -j, myIter, myThid )
116 IF (j.LE.listDim) wrFldList(j) = 'Vvel '
117
118 #if defined(ALLOW_EDDYPSI) && defined(ALLOW_GMREDI)
119 IF (GM_InMomAsStress) THEN
120 j = j + 1
121 CALL WRITE_REC_3D_RL( fn, fp, Nr, uEulerMean,
122 & -j, myIter, myThid )
123 IF (j.LE.listDim) wrFldList(j) = 'UEulerM '
124 j = j + 1
125 CALL WRITE_REC_3D_RL( fn, fp, Nr, vEulerMean,
126 & -j, myIter, myThid )
127 IF (j.LE.listDim) wrFldList(j) = 'VEulerM '
128 ENDIF
129 #endif
130
131 j = j + 1
132 CALL WRITE_REC_3D_RL( fn, fp, Nr, theta, -j, myIter, myThid )
133 IF (j.LE.listDim) wrFldList(j) = 'Theta '
134 j = j + 1
135 CALL WRITE_REC_3D_RL( fn, fp, Nr, salt, -j, myIter, myThid )
136 IF (j.LE.listDim) wrFldList(j) = 'Salt '
137 C--- write 3-D fields for AB-restart
138 #ifdef ALLOW_ADAMSBASHFORTH_3
139 m1 = 1 + MOD(myIter+1,2)
140 m2 = 1 + MOD( myIter ,2)
141 IF ( momStepping ) THEN
142 C-- U velocity:
143 IF ( alph_AB.NE.0. .OR. beta_AB.NE.0. ) THEN
144 j = j + 1
145 CALL WRITE_REC_3D_RL( fn, fp, Nr, guNm(1-OLx,1-OLy,1,1,1,m1),
146 & -j, myIter, myThid )
147 IF (j.LE.listDim) wrFldList(j) = 'GuNm1 '
148 ENDIF
149 IF ( beta_AB.NE.0. ) THEN
150 j = j + 1
151 CALL WRITE_REC_3D_RL( fn, fp, Nr, guNm(1-OLx,1-OLy,1,1,1,m2),
152 & -j, myIter, myThid )
153 IF (j.LE.listDim) wrFldList(j) = 'GuNm2 '
154 ENDIF
155 C-- V velocity:
156 IF ( alph_AB.NE.0. .OR. beta_AB.NE.0. ) THEN
157 j = j + 1
158 CALL WRITE_REC_3D_RL( fn, fp, Nr, gvNm(1-OLx,1-OLy,1,1,1,m1),
159 & -j, myIter, myThid )
160 IF (j.LE.listDim) wrFldList(j) = 'GvNm1 '
161 ENDIF
162 IF ( beta_AB.NE.0. ) THEN
163 j = j + 1
164 CALL WRITE_REC_3D_RL( fn, fp, Nr, gvNm(1-OLx,1-OLy,1,1,1,m2),
165 & -j, myIter, myThid )
166 IF (j.LE.listDim) wrFldList(j) = 'GvNm2 '
167 ENDIF
168 ENDIF
169 C-- Temperature:
170 IF ( AdamsBashforthGt.OR.AdamsBashforth_T ) THEN
171 IF ( alph_AB.NE.0. .OR. beta_AB.NE.0. ) THEN
172 j = j + 1
173 CALL WRITE_REC_3D_RL( fn, fp, Nr, gtNm(1-OLx,1-OLy,1,1,1,m1),
174 & -j, myIter, myThid )
175 IF (j.LE.listDim) THEN
176 IF ( AdamsBashforthGt ) wrFldList(j) = 'GtNm1 '
177 IF ( AdamsBashforth_T ) wrFldList(j) = 'TempNm1 '
178 ENDIF
179 ENDIF
180 IF ( beta_AB.NE.0. ) THEN
181 j = j + 1
182 CALL WRITE_REC_3D_RL( fn, fp, Nr, gtNm(1-OLx,1-OLy,1,1,1,m2),
183 & -j, myIter, myThid )
184 IF (j.LE.listDim) THEN
185 IF ( AdamsBashforthGt ) wrFldList(j) = 'GtNm2 '
186 IF ( AdamsBashforth_T ) wrFldList(j) = 'TempNm2 '
187 ENDIF
188 ENDIF
189 ENDIF
190 C-- Salinity:
191 IF ( AdamsBashforthGs.OR.AdamsBashforth_S ) THEN
192 IF ( alph_AB.NE.0. .OR. beta_AB.NE.0. ) THEN
193 j = j + 1
194 CALL WRITE_REC_3D_RL( fn, fp, Nr, gsNm(1-OLx,1-OLy,1,1,1,m1),
195 & -j, myIter, myThid )
196 IF (j.LE.listDim) THEN
197 IF ( AdamsBashforthGs ) wrFldList(j) = 'GsNm1 '
198 IF ( AdamsBashforth_S ) wrFldList(j) = 'SaltNm1 '
199 ENDIF
200 ENDIF
201 IF ( beta_AB.NE.0. ) THEN
202 j = j + 1
203 CALL WRITE_REC_3D_RL( fn, fp, Nr, gsNm(1-OLx,1-OLy,1,1,1,m2),
204 & -j, myIter, myThid )
205 IF (j.LE.listDim) THEN
206 IF ( AdamsBashforthGs ) wrFldList(j) = 'GsNm2 '
207 IF ( AdamsBashforth_S ) wrFldList(j) = 'SaltNm2 '
208 ENDIF
209 ENDIF
210 ENDIF
211 #ifdef ALLOW_NONHYDROSTATIC
212 C-- W velocity:
213 IF ( nonHydrostatic ) THEN
214 IF ( alph_AB.NE.0. .OR. beta_AB.NE.0. ) THEN
215 j = j + 1
216 CALL WRITE_REC_3D_RL( fn, fp, Nr, gwNm(1-OLx,1-OLy,1,1,1,m1),
217 & -j, myIter, myThid )
218 IF (j.LE.listDim) wrFldList(j) = 'GwNm1 '
219 ENDIF
220 IF ( beta_AB.NE.0. ) THEN
221 j = j + 1
222 CALL WRITE_REC_3D_RL( fn, fp, Nr, gwNm(1-OLx,1-OLy,1,1,1,m2),
223 & -j, myIter, myThid )
224 IF (j.LE.listDim) wrFldList(j) = 'GwNm2 '
225 ENDIF
226 ENDIF
227 #endif /* ALLOW_NONHYDROSTATIC */
228 #else /* ALLOW_ADAMSBASHFORTH_3 */
229 IF ( momStepping ) THEN
230 j = j + 1
231 CALL WRITE_REC_3D_RL( fn, fp, Nr, guNm1, -j, myIter, myThid )
232 IF (j.LE.listDim) wrFldList(j) = 'GuNm1 '
233 j = j + 1
234 CALL WRITE_REC_3D_RL( fn, fp, Nr, gvNm1, -j, myIter, myThid )
235 IF (j.LE.listDim) wrFldList(j) = 'GvNm1 '
236 ENDIF
237 IF ( AdamsBashforthGt.OR.AdamsBashforth_T ) THEN
238 j = j + 1
239 CALL WRITE_REC_3D_RL( fn, fp, Nr, gtNm1, -j, myIter, myThid )
240 IF (j.LE.listDim) THEN
241 IF ( AdamsBashforthGt ) wrFldList(j) = 'GtNm1 '
242 IF ( AdamsBashforth_T ) wrFldList(j) = 'TempNm1 '
243 ENDIF
244 ENDIF
245 IF ( AdamsBashforthGs.OR.AdamsBashforth_S ) THEN
246 j = j + 1
247 CALL WRITE_REC_3D_RL( fn, fp, Nr, gsNm1, -j, myIter, myThid )
248 IF (j.LE.listDim) THEN
249 IF ( AdamsBashforthGs ) wrFldList(j) = 'GsNm1 '
250 IF ( AdamsBashforth_S ) wrFldList(j) = 'SaltNm1 '
251 ENDIF
252 ENDIF
253 #ifdef ALLOW_NONHYDROSTATIC
254 IF ( nonHydrostatic ) THEN
255 j = j + 1
256 CALL WRITE_REC_3D_RL( fn, fp, Nr, gwNm1, -j, myIter, myThid )
257 IF (j.LE.listDim) wrFldList(j) = 'GwNm1 '
258 ENDIF
259 #endif /* ALLOW_NONHYDROSTATIC */
260 #endif /* ALLOW_ADAMSBASHFORTH_3 */
261
262 C- write Full Pressure for EOS in pressure:
263 IF ( storePhiHyd4Phys ) THEN
264 j = j + 1
265 CALL WRITE_REC_3D_RL( fn, fp, Nr,totPhiHyd,-j,myIter, myThid )
266 IF (j.LE.listDim) wrFldList(j) = 'PhiHyd '
267 ENDIF
268 #ifdef ALLOW_NONHYDROSTATIC
269 IF ( use3Dsolver ) THEN
270 j = j + 1
271 CALL WRITE_REC_3D_RL( fn, fp, Nr, phi_nh, -j, myIter, myThid )
272 IF (j.LE.listDim) wrFldList(j) = 'Phi_NHyd'
273 ENDIF
274 #endif /* ALLOW_NONHYDROSTATIC */
275 #ifdef ALLOW_ADDFLUID
276 C- write mass source/sink of fluid (but not needed if selectAddFluid=-1)
277 IF ( selectAddFluid.NE.0 ) THEN
278 j = j + 1
279 CALL WRITE_REC_3D_RL( fn, fp, Nr, addMass,-j, myIter, myThid )
280 IF (j.LE.listDim) wrFldList(j) = 'AddMass '
281 ENDIF
282 #endif /* ALLOW_ADDFLUID */
283 #ifdef ALLOW_FRICTION_HEATING
284 C- needs frictional heating when using synchronous time-stepping
285 IF ( addFrictionHeating .AND. .NOT.staggerTimeStep ) THEN
286 j = j + 1
287 CALL WRITE_REC_3D_RS( fn, fp, Nr, frictionHeating,
288 & -j, myIter, myThid )
289 IF (j.LE.listDim) wrFldList(j) = 'FricHeat'
290 ENDIF
291 #endif /* ALLOW_FRICTION_HEATING */
292
293 n3D = j
294 C--- Write 2-D fields, starting with Eta:
295 j = j + 1
296 nj = -( n3D*(Nr-1) + j )
297 CALL WRITE_REC_3D_RL( fn, fp, 1 , etaN, nj, myIter, myThid )
298 IF (j.LE.listDim) wrFldList(j) = 'EtaN '
299 #ifdef ALLOW_NONHYDROSTATIC
300 IF ( selectNHfreeSurf.GE.1 ) THEN
301 j = j + 1
302 nj = -( n3D*(Nr-1) + j )
303 CALL WRITE_REC_3D_RL( fn, fp, 1, dPhiNH, nj, myIter, myThid )
304 IF (j.LE.listDim) wrFldList(j) = 'dPhiNH '
305 ENDIF
306 #endif /* ALLOW_NONHYDROSTATIC */
307 #ifdef EXACT_CONSERV
308 c IF ( exactConserv ) THEN
309 j = j + 1
310 nj = -( n3D*(Nr-1) + j )
311 CALL WRITE_REC_3D_RL( fn, fp, 1, dEtaHdt, nj, myIter, myThid )
312 IF (j.LE.listDim) wrFldList(j) = 'dEtaHdt '
313 c ENDIF
314 C- note: always write dEtaHdt & EtaH but read only if exactConserv & nonlinFreeSurf
315 C this works only because nonlinFreeSurf > 0 => exactConserv=T
316 c IF ( nonlinFreeSurf.GT.0 ) THEN
317 j = j + 1
318 nj = -( n3D*(Nr-1) + j )
319 CALL WRITE_REC_3D_RL( fn, fp, 1, etaHnm1, nj, myIter, myThid )
320 IF (j.LE.listDim) wrFldList(j) = 'EtaH '
321 c ENDIF
322 #endif /* EXACT_CONSERV */
323 C--------------------------
324 nWrFlds = j
325 IF ( nWrFlds.GT.listDim ) THEN
326 WRITE(msgBuf,'(2A,I5,A)') 'WRITE_PICKUP: ',
327 & 'trying to write ',nWrFlds,' fields'
328 CALL PRINT_ERROR( msgBuf, myThid )
329 WRITE(msgBuf,'(2A,I5,A)') 'WRITE_PICKUP: ',
330 & 'field-list dimension (listDim=',listDim,') too small'
331 CALL PRINT_ERROR( msgBuf, myThid )
332 STOP 'ABNORMAL END: S/R WRITE_PICKUP (list-size Pb)'
333 ENDIF
334 #ifdef ALLOW_MDSIO
335 C- Note: temporary: since it is a pain to add more arguments to
336 C all MDSIO S/R, uses instead this specific S/R to write only
337 C meta files but with more informations in it.
338 nj = ABS(nj)
339 glf = globalFiles
340 timList(1) = myTime
341 CALL MDS_WR_METAFILES( fn, fp, glf, .FALSE.,
342 & 0, 0, 1, ' ',
343 & nWrFlds, wrFldList,
344 & 1, timList, oneRL,
345 & nj, myIter, myThid )
346 #endif /* ALLOW_MDSIO */
347 C--------------------------
348 ENDIF
349
350 #ifdef ALLOW_MNC
351 IF (useMNC .AND. pickup_write_mnc) THEN
352 IF ( permPickup ) THEN
353 WRITE(fn,'(A)') 'pickup'
354 ELSE
355 WRITE(fn,'(A,A)') 'pickup.',checkPtSuff(nCheckLev)
356 ENDIF
357 C First ***define*** the file group name
358 CALL MNC_CW_SET_UDIM(fn, 0, myThid)
359 IF ( permPickup ) THEN
360 CALL MNC_CW_SET_CITER(fn, 3, 3, myIter, 0, myThid)
361 ELSE
362 CALL MNC_CW_SET_CITER(fn, 2, -1, -1, -1, myThid)
363 ENDIF
364 C Then set the actual unlimited dimension
365 CALL MNC_CW_SET_UDIM(fn, 1, myThid)
366 CALL MNC_CW_RL_W_S('D',fn,0,0,'T', myTime, myThid)
367 CALL MNC_CW_I_W_S('I',fn,0,0,'iter', myIter, myThid)
368 CALL MNC_CW_RL_W('D',fn,0,0,'U', uVel, myThid)
369 CALL MNC_CW_RL_W('D',fn,0,0,'V', vVel, myThid)
370 #if defined(ALLOW_EDDYPSI) && defined(ALLOW_GMREDI)
371 IF (GM_InMomAsStress) THEN
372 CALL MNC_CW_RL_W('D',fn,0,0,'UEulerM', uEulerMean, myThid)
373 CALL MNC_CW_RL_W('D',fn,0,0,'VEulerM', vEulerMean, myThid)
374 ENDIF
375 #endif
376 CALL MNC_CW_RL_W('D',fn,0,0,'Temp', theta, myThid)
377 CALL MNC_CW_RL_W('D',fn,0,0,'S', salt, myThid)
378 CALL MNC_CW_RL_W('D',fn,0,0,'Eta', etaN, myThid)
379 #ifndef ALLOW_ADAMSBASHFORTH_3
380 CALL MNC_CW_RL_W('D',fn,0,0,'gUnm1', guNm1, myThid)
381 CALL MNC_CW_RL_W('D',fn,0,0,'gVnm1', gvNm1, myThid)
382 CALL MNC_CW_RL_W('D',fn,0,0,'gTnm1', gtNm1, myThid)
383 CALL MNC_CW_RL_W('D',fn,0,0,'gSnm1', gsNm1, myThid)
384 #endif /* ALLOW_ADAMSBASHFORTH_3 */
385 #ifdef EXACT_CONSERV
386 CALL MNC_CW_RL_W('D',fn,0,0,'dEtaHdt', dEtaHdt, myThid)
387 CALL MNC_CW_RL_W('D',fn,0,0,'EtaH', etaHnm1, myThid)
388 #endif
389 #ifdef ALLOW_NONHYDROSTATIC
390 IF ( use3Dsolver ) THEN
391 CALL MNC_CW_RL_W('D',fn,0,0,'phi_nh', phi_nh, myThid)
392 c CALL MNC_CW_RL_W('D',fn,0,0,'gW', gW, myThid)
393 #ifndef ALLOW_ADAMSBASHFORTH_3
394 CALL MNC_CW_RL_W('D',fn,0,0,'gWnm1', gwNm1, myThid)
395 #endif
396 ENDIF
397 #endif
398 IF ( storePhiHyd4Phys ) THEN
399 CALL MNC_CW_RL_W('D',fn,0,0,'phiHyd', totPhiHyd, myThid)
400 ENDIF
401 CALL MNC_FILE_CLOSE_ALL_MATCHING(fn, myThid)
402 ENDIF
403 #endif /* ALLOW_MNC */
404
405 C-- Every one else must wait until writing is done.
406 C this is done within IO routines => no longer needed
407 c _BARRIER
408
409 RETURN
410 END

  ViewVC Help
Powered by ViewVC 1.1.22