pkg/dic/dic_write_pickup.F

C $Header: /u/gcmpack/MITgcm/pkg/dic/dic_write_pickup.F,v 1.10 2013/11/20 16:01:04 jmc Exp $
C $Name:  $

#include "DIC_OPTIONS.h"

CBOP
C !ROUTINE: DIC_WRITE_PICKUP

C !INTERFACE: ==========================================================
      SUBROUTINE DIC_WRITE_PICKUP( permPickup,
     I                             suff, myTime, myIter, myThid )

C !DESCRIPTION:
C     Writes DIC arrays (needed for a restart) to a pickup file

C !USES: ===============================================================
      IMPLICIT NONE
C     === Global variables ===
#include "SIZE.h"
#include "EEPARAMS.h"
#include "PARAMS.h"
#include "DIC_VARS.h"
#include "DIC_ATMOS.h"

C !INPUT PARAMETERS: ===================================================
C     permPickup :: write a permanent pickup
C     suff       :: suffix for pickup file (eg. ckptA or 0000000010)
C     myTime     :: Current time in simulation
C     myIter     :: Current iteration number in simulation
C     myThid     :: My Thread Id number
      LOGICAL permPickup
      CHARACTER*(*) suff
      _RL     myTime
      INTEGER myIter
      INTEGER myThid
CEOP

#ifdef ALLOW_DIC

C     !LOCAL VARIABLES:
C     == Local variables ==
      CHARACTER*(MAX_LEN_FNAM) fn
      INTEGER prec
#ifndef USE_ATMOSCO2
      INTEGER ioUnit
      _RL tmpFld(2)
      _RS dummyRS(1)
#endif
#ifdef DIC_BIOTIC
      LOGICAL glf
      _RL     timList(1)
      INTEGER j, nj
      INTEGER listDim, nWrFlds
      PARAMETER( listDim = 2 )
      CHARACTER*(8) wrFldList(listDim)
      CHARACTER*(MAX_LEN_MBUF) msgBuf
#endif

c     IF ( DIC_pickup_write_mdsio ) THEN
        prec = precFloat64

#ifndef USE_ATMOSCO2
        IF ( dic_int1.EQ.3 ) THEN
          WRITE(fn,'(A,A)') 'pickup_dic_co2atm.',suff
          ioUnit = 0
#ifdef ALLOW_OPENAD
          tmpFld(1) = total_atmos_carbon%v
          tmpFld(2) = atpco2%v
#else /* ALLOW_OPENAD */
          tmpFld(1) = total_atmos_carbon
          tmpFld(2) = atpco2
#endif /* ALLOW_OPENAD */
#ifdef ALLOW_MDSIO
          CALL MDS_WRITEVEC_LOC(
     I                         fn, prec, ioUnit,
     I                         'RL', 2, tmpFld, dummyRS,
     I                         0, 0, 1, myIter, myThid )
#endif
        ENDIF
#endif /* ndef USE_ATMOSCO2 */

#ifdef DIC_BIOTIC
        WRITE(fn,'(A,A)') 'pickup_dic.',suff
        j = 0

C     Firstly, write 3-D fields as consecutive records,

C-    switch to 2-D fields:
        nj = -j*Nr

C       record number < 0 : a hack not to write meta files now:
        j = j + 1
        nj = nj-1
        CALL WRITE_REC_3D_RL( fn, prec, 1, pH, nj, myIter, myThid )
        IF (j.LE.listDim) wrFldList(j) = 'DIC_pH2d'

C--------------------------
        nWrFlds = j
        IF ( nWrFlds.GT.listDim ) THEN
          WRITE(msgBuf,'(2A,I5,A)') 'DIC_WRITE_PICKUP: ',
     &     'trying to write ',nWrFlds,' fields'
          CALL PRINT_ERROR( msgBuf, myThid )
          WRITE(msgBuf,'(2A,I5,A)') 'DIC_WRITE_PICKUP: ',
     &     'field-list dimension (listDim=',listDim,') too small'
          CALL PRINT_ERROR( msgBuf, myThid )
          STOP 'ABNORMAL END: S/R DIC_WRITE_PICKUP (list-size Pb)'
        ENDIF

#ifdef ALLOW_MDSIO
C     uses this specific S/R to write (with more informations) only meta
C     files
        j  = 1
        nj = ABS(nj)
        IF ( nWrFlds*Nr .EQ. nj ) THEN
          j  = Nr
          nj = nWrFlds
        ENDIF
        glf  = globalFiles
        timList(1) = myTime
        CALL MDS_WR_METAFILES( fn, prec, glf, .FALSE.,
     &                         0, 0, j, ' ',
     &                         nWrFlds, wrFldList,
     &                         1, timList, oneRL,
     &                         nj, myIter, myThid )
#endif /* ALLOW_MDSIO */
C--------------------------

#endif /* DIC_BIOTIC  */

c     ENDIF /* DIC_pickup_write_mdsio */

#endif /* ALLOW_DIC  */

      RETURN
      END
1	jmc	1.11	C $Header: /u/gcmpack/MITgcm/pkg/dic/dic_write_pickup.F,v 1.10 2013/11/20 16:01:04 jmc Exp $
2	dfer	1.1	C $Name: $
3
4			#include "DIC_OPTIONS.h"
5
6	jmc	1.4	CBOP
7			C !ROUTINE: DIC_WRITE_PICKUP
8	dfer	1.1
9	jmc	1.4	C !INTERFACE: ==========================================================
10			SUBROUTINE DIC_WRITE_PICKUP( permPickup,
11			I suff, myTime, myIter, myThid )
12
13			C !DESCRIPTION:
14			C Writes DIC arrays (needed for a restart) to a pickup file
15
16			C !USES: ===============================================================
17	dfer	1.1	IMPLICIT NONE
18			C === Global variables ===
19			#include "SIZE.h"
20			#include "EEPARAMS.h"
21			#include "PARAMS.h"
22	dfer	1.2	#include "DIC_VARS.h"
23	jmc	1.6	#include "DIC_ATMOS.h"
24	dfer	1.1
25	jmc	1.4	C !INPUT PARAMETERS: ===================================================
26	dfer	1.1	C permPickup :: write a permanent pickup
27	jmc	1.4	C suff :: suffix for pickup file (eg. ckptA or 0000000010)
28			C myTime :: Current time in simulation
29			C myIter :: Current iteration number in simulation
30			C myThid :: My Thread Id number
31	dfer	1.1	LOGICAL permPickup
32			CHARACTER() suff
33			_RL myTime
34			INTEGER myIter
35			INTEGER myThid
36	jmc	1.4	CEOP
37	dfer	1.1
38			#ifdef ALLOW_DIC
39
40			C !LOCAL VARIABLES:
41			C == Local variables ==
42			CHARACTER*(MAX_LEN_FNAM) fn
43	jmc	1.6	INTEGER prec
44			#ifndef USE_ATMOSCO2
45			INTEGER ioUnit
46	jmc	1.10	_RL tmpFld(2)
47	jmc	1.6	_RS dummyRS(1)
48			#endif
49			#ifdef DIC_BIOTIC
50	jmc	1.3	LOGICAL glf
51	jmc	1.7	_RL timList(1)
52	jmc	1.6	INTEGER j, nj
53	jmc	1.3	INTEGER listDim, nWrFlds
54			PARAMETER( listDim = 2 )
55			CHARACTER*(8) wrFldList(listDim)
56			CHARACTER*(MAX_LEN_MBUF) msgBuf
57	jmc	1.6	#endif
58
59	jmc	1.3	c IF ( DIC_pickup_write_mdsio ) THEN
60			prec = precFloat64
61	jmc	1.6
62			#ifndef USE_ATMOSCO2
63			IF ( dic_int1.EQ.3 ) THEN
64			WRITE(fn,'(A,A)') 'pickup_dic_co2atm.',suff
65			ioUnit = 0
66	jmc	1.11	#ifdef ALLOW_OPENAD
67	jmc	1.10	tmpFld(1) = total_atmos_carbon%v
68			tmpFld(2) = atpco2%v
69	jmc	1.11	#else /* ALLOW_OPENAD */
70	jmc	1.10	tmpFld(1) = total_atmos_carbon
71			tmpFld(2) = atpco2
72	jmc	1.11	#endif /* ALLOW_OPENAD */
73	jmc	1.6	#ifdef ALLOW_MDSIO
74			CALL MDS_WRITEVEC_LOC(
75			I fn, prec, ioUnit,
76	jmc	1.10	I 'RL', 2, tmpFld, dummyRS,
77	jmc	1.6	I 0, 0, 1, myIter, myThid )
78			#endif
79			ENDIF
80			#endif /* ndef USE_ATMOSCO2 */
81
82			#ifdef DIC_BIOTIC
83	jmc	1.3	WRITE(fn,'(A,A)') 'pickup_dic.',suff
84			j = 0
85
86			C Firstly, write 3-D fields as consecutive records,
87
88			C- switch to 2-D fields:
89			nj = -j*Nr
90
91			C record number < 0 : a hack not to write meta files now:
92			j = j + 1
93			nj = nj-1
94			CALL WRITE_REC_3D_RL( fn, prec, 1, pH, nj, myIter, myThid )
95			IF (j.LE.listDim) wrFldList(j) = 'DIC_pH2d'
96
97			C--------------------------
98			nWrFlds = j
99			IF ( nWrFlds.GT.listDim ) THEN
100			WRITE(msgBuf,'(2A,I5,A)') 'DIC_WRITE_PICKUP: ',
101			& 'trying to write ',nWrFlds,' fields'
102			CALL PRINT_ERROR( msgBuf, myThid )
103			WRITE(msgBuf,'(2A,I5,A)') 'DIC_WRITE_PICKUP: ',
104			& 'field-list dimension (listDim=',listDim,') too small'
105			CALL PRINT_ERROR( msgBuf, myThid )
106			STOP 'ABNORMAL END: S/R DIC_WRITE_PICKUP (list-size Pb)'
107			ENDIF
108
109			#ifdef ALLOW_MDSIO
110			C uses this specific S/R to write (with more informations) only meta
111			C files
112			j = 1
113			nj = ABS(nj)
114			IF ( nWrFlds*Nr .EQ. nj ) THEN
115			j = Nr
116			nj = nWrFlds
117			ENDIF
118			glf = globalFiles
119	jmc	1.7	timList(1) = myTime
120	jmc	1.3	CALL MDS_WR_METAFILES( fn, prec, glf, .FALSE.,
121			& 0, 0, j, ' ',
122			& nWrFlds, wrFldList,
123	jmc	1.8	& 1, timList, oneRL,
124	jmc	1.3	& nj, myIter, myThid )
125			#endif /* ALLOW_MDSIO */
126			C--------------------------
127	dfer	1.1
128	jmc	1.6	#endif /* DIC_BIOTIC */
129
130	jmc	1.3	c ENDIF /* DIC_pickup_write_mdsio */
131	dfer	1.1
132	jmc	1.6	#endif /* ALLOW_DIC */
133	dfer	1.1
134			RETURN
135			END