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

Contents of /MITgcm_contrib/llc_hires/llc_90/code-async-noseaice/write_pickup.F

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


Revision 1.1 - (show annotations) (download)
Mon Oct 9 02:02:49 2017 UTC (7 years, 9 months ago) by dimitri
Branch: MAIN
CVS Tags: HEAD
adding asyncio experiment without seaice

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

  ViewVC Help
Powered by ViewVC 1.1.22