/[MITgcm]/MITgcm_contrib/llc_hires/llc_4320/code-async/write_pickup.F
ViewVC logotype

Contents of /MITgcm_contrib/llc_hires/llc_4320/code-async/write_pickup.F

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


Revision 1.4 - (show annotations) (download)
Thu Apr 14 03:51:44 2016 UTC (9 years, 3 months ago) by dimitri
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +32 -17 lines
updating for checkpoint65v

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

  ViewVC Help
Powered by ViewVC 1.1.22