source: trunk/LMDZ.GENERIC/libf/dyn3d/write_archive.F @ 588

Last change on this file since 588 was 135, checked in by aslmd, 14 years ago

CHANGEMENT ARBORESCENCE ETAPE 2 -- NON COMPLET
File size: 6.7 KB
RevLine 
[135]1c=======================================================================
2      subroutine write_archive(nid,ntime,nom,titre,unite,dim,px)
3c=======================================================================
4c
5c
6c   Date:    01/1997
7c   ----
8c
9c   Objet:   Ecriture de champs sur grille scalaire (iip1*jjp1)
10c   -----    dans un fichier DRS nomme "start_archive"
11c
12c    Il faut au prealable avoir cree un entete avec un "call ini_archive".
13c    Ces variables peuvent etre 3d (ex: temperature), 2d (ex: temperature
14c    de surface), ou 0d (pour un scalaire qui ne depend que du temps)
15c    (ex: la longitude solaire)
16c
17c
18c   Arguments:
19c   ----------
20c
21c     Inputs:
22c     ------
23c
24c                 nid      Unite logique du fichier "start_archive"
25c         nom      nom du champ a ecrire dans le fichier "start_archive"
26c         titre    titre de la variable dans le fichier DRS "start_archive"
27c         unite    unite de la variable ....
28c         dim      dimension de la variable a ecrire
29c         px       tableau contenant la variable a ecrire
30c
31c
32c=======================================================================
33
34      implicit none
35
36#include "dimensions.h"
37#include "dimphys.h"
38#include "paramet.h"
39#include "control.h"
40#include "comvert.h"
41#include "comgeom.h"
42#include "description.h"
43#include "temps.h"
44#include "netcdf.inc"
45
46c-----------------------------------------------------------------------
47c       Declarations   
48c-----------------------------------------------------------------------
49
50c Arguments:
51
52      INTEGER nid
53      integer ntime ! time index
54      integer dim
55      REAL px(iip1,jjp1,llm)
56
57      CHARACTER*(*) nom, titre, unite
58
59      integer ierr
60
61
62c local
63      integer, dimension(4) :: edges,corner,id
64      integer :: varid,i,j,l
65c-----------------------------------------------------------------------
66c      Ecriture du champs dans le fichier            (3 cas)     
67c-----------------------------------------------------------------------
68
69! For an atmospheric 3D Variable
70!--------------------------------
71        if (dim.eq.3) then
72
73!         Ecriture du champs
74
75! nom de la variable
76           ierr= NF_INQ_VARID(nid,nom,varid)
77           if (ierr /= NF_NOERR) then
78! choix du nom des coordonnees
79              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
80              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
81              ierr= NF_INQ_DIMID(nid,"altitude",id(3))
82              ierr= NF_INQ_DIMID(nid,"Time",id(4))
83
84! Creation de la variable si elle n'existait pas
85
86              write (*,*) "====================="
87              write (*,*) "creation de ",nom
88              call def_var(nid,nom,titre,unite,4,id,varid,ierr)
89
90           endif
91
92! mars s'arranger pour qu'il n'y ai plus besoin de ca
93
94c          do l=1,llm
95c             do j=1,jjp1
96c                do i=1,iip1
97c                   pxbis(i,j,l)=px(i,j,llm-l+1)
98c                enddo
99c             enddo
100c          enddo
101           corner(1)=1
102           corner(2)=1
103           corner(3)=1
104           corner(4)=ntime
105
106           edges(1)=iip1
107           edges(2)=jjp1
108           edges(3)=llm
109           edges(4)=1
110#ifdef NC_DOUBLE
111           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
112#else
113           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
114#endif
115
116           if (ierr.ne.NF_NOERR) then
117              write(*,*) "***** PUT_VAR matter in write_archive"
118              write(*,*) "***** with ",nom," ",nf_STRERROR(ierr)
119              call abort
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           write(*,*)"write_archive: dimension <subsurface_layers>",
137     &               " is missing !!!"
138           call abort
139          endif
140          ierr=NF_INQ_DIMID(nid,"Time",id(4))
141         
142          ! define the variable
143          write(*,*)"====================="
144          write(*,*)"defining ",nom
145          call def_var(nid,nom,titre,unite,4,id,varid,ierr)
146         
147         endif
148
149        ! build cedges and corners
150        corner(1)=1
151        corner(2)=1
152        corner(3)=1
153        corner(4)=ntime
154
155        edges(1)=iip1
156        edges(2)=jjp1
157        edges(3)=nsoilmx
158        edges(4)=1
159#ifdef NC_DOUBLE
160           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
161#else
162           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
163#endif
164
165
166! For a surface 2D Variable
167!--------------------------
168
169        else if (dim.eq.2) then
170
171!         Ecriture du champs
172
173           ierr= NF_INQ_VARID(nid,nom,varid)
174           if (ierr /= NF_NOERR) then
175!  choix du nom des coordonnees
176              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
177              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
178              ierr= NF_INQ_DIMID(nid,"Time",id(3))
179
180! Creation de la variable si elle n'existait pas
181
182              write (*,*) "====================="
183              write (*,*) "creation de ",nom
184
185              call def_var(nid,nom,titre,unite,3,id,varid,ierr)
186
187           endif
188
189           corner(1)=1
190           corner(2)=1
191           corner(3)=ntime
192           edges(1)=iip1
193           edges(2)=jjp1
194           edges(3)=1
195
196
197#ifdef NC_DOUBLE
198           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px)
199#else         
200           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
201#endif     
202
203           if (ierr.ne.NF_NOERR) then
204              write(*,*) "***** PUT_VAR matter in write_archive"
205              write(*,*) "***** with ",nom,nf_STRERROR(ierr)
206              call abort
207           endif
208
209
210!Cas Variable 0D (scalaire dependant du temps)
211!---------------------------------------------
212
213        else if (dim.eq.0) then
214
215!         Ecriture du champs
216
217           ierr= NF_INQ_VARID(nid,nom,varid)
218           if (ierr /= NF_NOERR) then
219!  choix du nom des coordonnees
220              ierr= NF_INQ_DIMID(nid,"Time",id(1))
221
222! Creation de la variable si elle n'existait pas
223
224              write (*,*) "====================="
225              write (*,*) "creation de ",nom
226
227              call def_var(nid,nom,titre,unite,1,id,varid,ierr)
228
229           endif
230
231           corner(1)=ntime
232           edges(1)=1
233
234#ifdef NC_DOUBLE
235           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px)
236#else
237           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
238#endif
239           if (ierr.ne.NF_NOERR) then
240              write(*,*) "***** PUT_VAR matter in write_archive"
241              write(*,*) "***** with ",nom,nf_STRERROR(ierr)
242              call abort
243           endif
244
245        else
246          write(*,*) "write_archive: dim=",dim," ?!?"
247          call abort
248        endif ! of if (dim.eq.3) else if (dim.eq.-3) ....
249
250      return
251      end
252
Note: See TracBrowser for help on using the repository browser.