Context Navigation

write_archive.F @ 3981

Last change on this file since 3981 was 3893, checked in by gmilcareck, 4 months ago
Remove all "call abort" and "stop" statement in LMDZ.GENERIC and replacing them by call abort_physic().
File size: 8.3 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	USE ocean_slab_mod, ONLY: nslay
37
38	implicit none
39
40	include "dimensions.h"
41	include "paramet.h"
42	include "comgeom.h"
43	include "netcdf.inc"
44
45	c-----------------------------------------------------------------------
46	c Declarations
47	c-----------------------------------------------------------------------
48
49	c Arguments:
50
51	INTEGER nid
52	integer ntime ! time index
53	integer dim
54	REAL px(iip1,jjp1,llm)
55
56	CHARACTER() nom, titre, unite
57
58	integer ierr
59
60
61	c local
62	integer, dimension(4) :: edges,corner,id
63	integer :: varid,i,j,l
64	c-----------------------------------------------------------------------
65	c Ecriture du champs dans le fichier (3 cas)
66	c-----------------------------------------------------------------------
67
68	! For an atmospheric 3D Variable
69	!--------------------------------
70	if (dim.eq.3) then
71
72	! Ecriture du champs
73
74	! nom de la variable
75	ierr= NF_INQ_VARID(nid,nom,varid)
76	if (ierr /= NF_NOERR) then
77	! choix du nom des coordonnees
78	ierr= NF_INQ_DIMID(nid,"longitude",id(1))
79	ierr= NF_INQ_DIMID(nid,"latitude",id(2))
80	ierr= NF_INQ_DIMID(nid,"altitude",id(3))
81	ierr= NF_INQ_DIMID(nid,"Time",id(4))
82
83	! Creation de la variable si elle n'existait pas
84
85	write (,) "====================="
86	write (,) "defining ",nom
87	call def_var(nid,nom,titre,unite,4,id,varid,ierr)
88
89	endif
90
91	! mars s'arranger pour qu'il n'y ai plus besoin de ca
92
93	c do l=1,llm
94	c do j=1,jjp1
95	c do i=1,iip1
96	c pxbis(i,j,l)=px(i,j,llm-l+1)
97	c enddo
98	c enddo
99	c enddo
100	corner(1)=1
101	corner(2)=1
102	corner(3)=1
103	corner(4)=ntime
104
105	edges(1)=iip1
106	edges(2)=jjp1
107	edges(3)=llm
108	edges(4)=1
109	#ifdef NC_DOUBLE
110	ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
111	#else
112	ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
113	#endif
114
115	if (ierr.ne.NF_NOERR) then
116	write(,) "***** PUT_VAR problem in write_archive"
117	write(,) "***** with ",trim(nom)," ",nf_STRERROR(ierr)
118	call abort_physic("write_archive",
119	& "PUT_VAR problem in write_archive", 1)
120	endif
121
122
123	! For a subterranean 3D Variable
124	!-------------------------------
125
126	else if (dim.eq.-3) then
127	! get variables' ID, if it exists
128	ierr=NF_INQ_VARID(nid,nom,varid)
129
130	if (ierr.ne.NF_NOERR) then ! variable not defined yet
131	! build related coordinates
132	ierr=NF_INQ_DIMID(nid,"longitude",id(1))
133	ierr=NF_INQ_DIMID(nid,"latitude",id(2))
134	ierr=NF_INQ_DIMID(nid,"subsurface_layers",id(3))
135	if (ierr.ne.NF_NOERR) then
136	call abort_physic("write_archive",
137	& "dimension <subsurface_layers> is missing",1)
138	endif
139	ierr=NF_INQ_DIMID(nid,"Time",id(4))
140
141	! define the variable
142	write(,)"====================="
143	write(,)"defining variable ",trim(nom)
144	call def_var(nid,nom,titre,unite,4,id,varid,ierr)
145
146	endif
147
148	! build cedges and corners
149	corner(1)=1
150	corner(2)=1
151	corner(3)=1
152	corner(4)=ntime
153
154	edges(1)=iip1
155	edges(2)=jjp1
156	edges(3)=nsoilmx
157	edges(4)=1
158	#ifdef NC_DOUBLE
159	ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
160	#else
161	ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
162	#endif
163
164	! For a 3D ocean temperature Variable
165	!-------------------------------
166
167	else if (dim.eq.-2) then
168	! get variables' ID, if it exists
169	ierr=NF_INQ_VARID(nid,nom,varid)
170
171	if (ierr.ne.NF_NOERR) then ! variable not defined yet
172	! build related coordinates
173	ierr=NF_INQ_DIMID(nid,"longitude",id(1))
174	ierr=NF_INQ_DIMID(nid,"latitude",id(2))
175	ierr=NF_INQ_DIMID(nid,"ocean_layers",id(3))
176	if (ierr.ne.NF_NOERR) then
177	call abort_physic("write_archive",
178	& "dimension <ocean_layers> is missing",1)
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)=nslay
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_physic("write_archive",
248	& "PUT_VAR problem in write_archive",1)
249	endif
250
251
252	!Cas Variable 0D (scalaire dependant du temps)
253	!---------------------------------------------
254
255	else if (dim.eq.0) then
256
257	! Ecriture du champs
258
259	ierr= NF_INQ_VARID(nid,nom,varid)
260	if (ierr /= NF_NOERR) then
261	! choix du nom des coordonnees
262	ierr= NF_INQ_DIMID(nid,"Time",id(1))
263
264	! Creation de la variable si elle n'existait pas
265
266	write (,) "====================="
267	write (,) "defining variable ",trim(nom)
268
269	call def_var(nid,nom,titre,unite,1,id,varid,ierr)
270
271	endif
272
273	corner(1)=ntime
274	edges(1)=1
275
276	#ifdef NC_DOUBLE
277	ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px)
278	#else
279	ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
280	#endif
281	if (ierr.ne.NF_NOERR) then
282	write(,) "***** PUT_VAR problem in write_archive"
283	write(,) "***** with ",nom,nf_STRERROR(ierr)
284	call abort_physic("write_archive",
285	& "PUT_VAR problem in write_archive",1)
286	endif
287
288	else
289	write(,) "write_archive: dim=",dim," ?!?"
290	call abort_physic("write_archive",
291	& "dim problem in write_archive",1)
292	endif ! of if (dim.eq.3) else if (dim.eq.-3) ....
293
294	end
295

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

Download in other formats:

Original Format