Context Navigation

write_archive.F @ 2613

Last change on this file since 2613 was 2336, checked in by emillour, 5 years ago
Generic GCM: Update start2archive/newstart programs to handle recently introduced non-orographic GW variables in (re-)start files. EM
File size: 8.0 KB

Line
1	c=======================================================================
2	subroutine write_archive(nid,ntime,nom,titre,unite,dim,px)
3	c=======================================================================
4	c
5	c
6	c Date: 01/1997
7	c ----
8	c
9	c Objet: Ecriture de champs sur grille scalaire (iip1*jjp1)
10	c ----- dans un fichier DRS nomme "start_archive"
11	c
12	c Il faut au prealable avoir cree un entete avec un "call ini_archive".
13	c Ces variables peuvent etre 3d (ex: temperature), 2d (ex: temperature
14	c de surface), ou 0d (pour un scalaire qui ne depend que du temps)
15	c (ex: la longitude solaire)
16	c
17	c
18	c Arguments:
19	c ----------
20	c
21	c Inputs:
22	c ------
23	c
24	c nid Unite logique du fichier "start_archive"
25	c nom nom du champ a ecrire dans le fichier "start_archive"
26	c titre titre de la variable dans le fichier DRS "start_archive"
27	c unite unite de la variable ....
28	c dim dimension de la variable a ecrire
29	c px tableau contenant la variable a ecrire
30	c
31	c
32	c=======================================================================
33
34	use comsoil_h, only: nsoilmx
35	use slab_ice_h, only: noceanmx
36
37	implicit none
38
39	include "dimensions.h"
40	include "paramet.h"
41	include "comgeom.h"
42	include "netcdf.inc"
43
44	c-----------------------------------------------------------------------
45	c Declarations
46	c-----------------------------------------------------------------------
47
48	c Arguments:
49
50	INTEGER nid
51	integer ntime ! time index
52	integer dim
53	REAL px(iip1,jjp1,llm)
54
55	CHARACTER() nom, titre, unite
56
57	integer ierr
58
59
60	c local
61	integer, dimension(4) :: edges,corner,id
62	integer :: varid,i,j,l
63	c-----------------------------------------------------------------------
64	c Ecriture du champs dans le fichier (3 cas)
65	c-----------------------------------------------------------------------
66
67	! For an atmospheric 3D Variable
68	!--------------------------------
69	if (dim.eq.3) then
70
71	! Ecriture du champs
72
73	! nom de la variable
74	ierr= NF_INQ_VARID(nid,nom,varid)
75	if (ierr /= NF_NOERR) then
76	! choix du nom des coordonnees
77	ierr= NF_INQ_DIMID(nid,"longitude",id(1))
78	ierr= NF_INQ_DIMID(nid,"latitude",id(2))
79	ierr= NF_INQ_DIMID(nid,"altitude",id(3))
80	ierr= NF_INQ_DIMID(nid,"Time",id(4))
81
82	! Creation de la variable si elle n'existait pas
83
84	write (,) "====================="
85	write (,) "defining ",nom
86	call def_var(nid,nom,titre,unite,4,id,varid,ierr)
87
88	endif
89
90	! mars s'arranger pour qu'il n'y ai plus besoin de ca
91
92	c do l=1,llm
93	c do j=1,jjp1
94	c do i=1,iip1
95	c pxbis(i,j,l)=px(i,j,llm-l+1)
96	c enddo
97	c enddo
98	c enddo
99	corner(1)=1
100	corner(2)=1
101	corner(3)=1
102	corner(4)=ntime
103
104	edges(1)=iip1
105	edges(2)=jjp1
106	edges(3)=llm
107	edges(4)=1
108	#ifdef NC_DOUBLE
109	ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
110	#else
111	ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
112	#endif
113
114	if (ierr.ne.NF_NOERR) then
115	write(,) "***** PUT_VAR problem in write_archive"
116	write(,) "***** with ",trim(nom)," ",nf_STRERROR(ierr)
117	call abort
118	endif
119
120
121	! For a subterranean 3D Variable
122	!-------------------------------
123
124	else if (dim.eq.-3) then
125	! get variables' ID, if it exists
126	ierr=NF_INQ_VARID(nid,nom,varid)
127
128	if (ierr.ne.NF_NOERR) then ! variable not defined yet
129	! build related coordinates
130	ierr=NF_INQ_DIMID(nid,"longitude",id(1))
131	ierr=NF_INQ_DIMID(nid,"latitude",id(2))
132	ierr=NF_INQ_DIMID(nid,"subsurface_layers",id(3))
133	if (ierr.ne.NF_NOERR) then
134	write(,)"write_archive: dimension <subsurface_layers>",
135	& " is missing !!!"
136	call abort
137	endif
138	ierr=NF_INQ_DIMID(nid,"Time",id(4))
139
140	! define the variable
141	write(,)"====================="
142	write(,)"defining variable ",trim(nom)
143	call def_var(nid,nom,titre,unite,4,id,varid,ierr)
144
145	endif
146
147	! build cedges and corners
148	corner(1)=1
149	corner(2)=1
150	corner(3)=1
151	corner(4)=ntime
152
153	edges(1)=iip1
154	edges(2)=jjp1
155	edges(3)=nsoilmx
156	edges(4)=1
157	#ifdef NC_DOUBLE
158	ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
159	#else
160	ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
161	#endif
162
163	! For a 3D ocean temperature Variable
164	!-------------------------------
165
166	else if (dim.eq.-2) then
167	! get variables' ID, if it exists
168	ierr=NF_INQ_VARID(nid,nom,varid)
169
170	if (ierr.ne.NF_NOERR) then ! variable not defined yet
171	! build related coordinates
172	ierr=NF_INQ_DIMID(nid,"longitude",id(1))
173	ierr=NF_INQ_DIMID(nid,"latitude",id(2))
174	ierr=NF_INQ_DIMID(nid,"ocean_layers",id(3))
175	if (ierr.ne.NF_NOERR) then
176	write(,)"write_archive: dimension <ocean_layers>",
177	& " is missing !!!"
178	call abort
179	endif
180	ierr=NF_INQ_DIMID(nid,"Time",id(4))
181
182	! define the variable
183	write(,)"====================="
184	write(,)"defining variable ",trim(nom)
185	call def_var(nid,nom,titre,unite,4,id,varid,ierr)
186
187	endif
188
189	! build cedges and corners
190	corner(1)=1
191	corner(2)=1
192	corner(3)=1
193	corner(4)=ntime
194
195	edges(1)=iip1
196	edges(2)=jjp1
197	edges(3)=noceanmx
198	edges(4)=1
199	#ifdef NC_DOUBLE
200	ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
201	#else
202	ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
203	#endif
204
205
206
207	! For a surface 2D Variable
208	!--------------------------
209
210	else if (dim.eq.2) then
211
212	! Ecriture du champs
213
214	ierr= NF_INQ_VARID(nid,nom,varid)
215	if (ierr /= NF_NOERR) then
216	! choix du nom des coordonnees
217	ierr= NF_INQ_DIMID(nid,"longitude",id(1))
218	ierr= NF_INQ_DIMID(nid,"latitude",id(2))
219	ierr= NF_INQ_DIMID(nid,"Time",id(3))
220
221	! Creation de la variable si elle n'existait pas
222
223	write (,) "====================="
224	write (,) "defining variable ",trim(nom)
225
226	call def_var(nid,nom,titre,unite,3,id,varid,ierr)
227
228	endif
229
230	corner(1)=1
231	corner(2)=1
232	corner(3)=ntime
233	edges(1)=iip1
234	edges(2)=jjp1
235	edges(3)=1
236
237
238	#ifdef NC_DOUBLE
239	ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px)
240	#else
241	ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
242	#endif
243
244	if (ierr.ne.NF_NOERR) then
245	write(,) "***** PUT_VAR problem in write_archive"
246	write(,) "***** with ",nom,nf_STRERROR(ierr)
247	call abort
248	endif
249
250
251	!Cas Variable 0D (scalaire dependant du temps)
252	!---------------------------------------------
253
254	else if (dim.eq.0) then
255
256	! Ecriture du champs
257
258	ierr= NF_INQ_VARID(nid,nom,varid)
259	if (ierr /= NF_NOERR) then
260	! choix du nom des coordonnees
261	ierr= NF_INQ_DIMID(nid,"Time",id(1))
262
263	! Creation de la variable si elle n'existait pas
264
265	write (,) "====================="
266	write (,) "defining variable ",trim(nom)
267
268	call def_var(nid,nom,titre,unite,1,id,varid,ierr)
269
270	endif
271
272	corner(1)=ntime
273	edges(1)=1
274
275	#ifdef NC_DOUBLE
276	ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px)
277	#else
278	ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
279	#endif
280	if (ierr.ne.NF_NOERR) then
281	write(,) "***** PUT_VAR problem in write_archive"
282	write(,) "***** with ",nom,nf_STRERROR(ierr)
283	call abort
284	endif
285
286	else
287	write(,) "write_archive: dim=",dim," ?!?"
288	call abort
289	endif ! of if (dim.eq.3) else if (dim.eq.-3) ....
290
291	end
292

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format