source: trunk/LMDZ.GENERIC/libf/dynlonlat_phylonlat/phystd/write_archive.F @ 1477

Last change on this file since 1477 was 1422, checked in by milmd, 10 years ago

In GENERIC, MARS and COMMON models replace some include files by modules (usefull for decoupling physics with dynamics).
File size: 6.7 KB
Line 
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      use comsoil_h, only: nsoilmx
35      implicit none
36
37#include "dimensions.h"
38#include "paramet.h"
39#include "comgeom.h"
40#include "netcdf.inc"
41
42c-----------------------------------------------------------------------
43c       Declarations   
44c-----------------------------------------------------------------------
45
46c Arguments:
47
48      INTEGER nid
49      integer ntime ! time index
50      integer dim
51      REAL px(iip1,jjp1,llm)
52
53      CHARACTER*(*) nom, titre, unite
54
55      integer ierr
56
57
58c local
59      integer, dimension(4) :: edges,corner,id
60      integer :: varid,i,j,l
61c-----------------------------------------------------------------------
62c      Ecriture du champs dans le fichier            (3 cas)     
63c-----------------------------------------------------------------------
64
65! For an atmospheric 3D Variable
66!--------------------------------
67        if (dim.eq.3) then
68
69!         Ecriture du champs
70
71! nom de la variable
72           ierr= NF_INQ_VARID(nid,nom,varid)
73           if (ierr /= NF_NOERR) then
74! choix du nom des coordonnees
75              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
76              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
77              ierr= NF_INQ_DIMID(nid,"altitude",id(3))
78              ierr= NF_INQ_DIMID(nid,"Time",id(4))
79
80! Creation de la variable si elle n'existait pas
81
82              write (*,*) "====================="
83              write (*,*) "creation de ",nom
84              call def_var(nid,nom,titre,unite,4,id,varid,ierr)
85
86           endif
87
88! mars s'arranger pour qu'il n'y ai plus besoin de ca
89
90c          do l=1,llm
91c             do j=1,jjp1
92c                do i=1,iip1
93c                   pxbis(i,j,l)=px(i,j,llm-l+1)
94c                enddo
95c             enddo
96c          enddo
97           corner(1)=1
98           corner(2)=1
99           corner(3)=1
100           corner(4)=ntime
101
102           edges(1)=iip1
103           edges(2)=jjp1
104           edges(3)=llm
105           edges(4)=1
106#ifdef NC_DOUBLE
107           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
108#else
109           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
110#endif
111
112           if (ierr.ne.NF_NOERR) then
113              write(*,*) "***** PUT_VAR matter in write_archive"
114              write(*,*) "***** with ",nom," ",nf_STRERROR(ierr)
115              call abort
116           endif
117
118
119! For a subterranean 3D Variable
120!-------------------------------
121
122        else if (dim.eq.-3) then
123        ! get variables' ID, if it exists
124        ierr=NF_INQ_VARID(nid,nom,varid)
125       
126         if (ierr.ne.NF_NOERR) then ! variable not defined yet
127          ! build related coordinates
128          ierr=NF_INQ_DIMID(nid,"longitude",id(1))
129          ierr=NF_INQ_DIMID(nid,"latitude",id(2))
130          ierr=NF_INQ_DIMID(nid,"subsurface_layers",id(3))
131          if (ierr.ne.NF_NOERR) then
132           write(*,*)"write_archive: dimension <subsurface_layers>",
133     &               " is missing !!!"
134           call abort
135          endif
136          ierr=NF_INQ_DIMID(nid,"Time",id(4))
137         
138          ! define the variable
139          write(*,*)"====================="
140          write(*,*)"defining ",nom
141          call def_var(nid,nom,titre,unite,4,id,varid,ierr)
142         
143         endif
144
145        ! build cedges and corners
146        corner(1)=1
147        corner(2)=1
148        corner(3)=1
149        corner(4)=ntime
150
151        edges(1)=iip1
152        edges(2)=jjp1
153        edges(3)=nsoilmx
154        edges(4)=1
155#ifdef NC_DOUBLE
156           ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px)
157#else
158           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
159#endif
160
161
162! For a surface 2D Variable
163!--------------------------
164
165        else if (dim.eq.2) then
166
167!         Ecriture du champs
168
169           ierr= NF_INQ_VARID(nid,nom,varid)
170           if (ierr /= NF_NOERR) then
171!  choix du nom des coordonnees
172              ierr= NF_INQ_DIMID(nid,"longitude",id(1))
173              ierr= NF_INQ_DIMID(nid,"latitude",id(2))
174              ierr= NF_INQ_DIMID(nid,"Time",id(3))
175
176! Creation de la variable si elle n'existait pas
177
178              write (*,*) "====================="
179              write (*,*) "creation de ",nom
180
181              call def_var(nid,nom,titre,unite,3,id,varid,ierr)
182
183           endif
184
185           corner(1)=1
186           corner(2)=1
187           corner(3)=ntime
188           edges(1)=iip1
189           edges(2)=jjp1
190           edges(3)=1
191
192
193#ifdef NC_DOUBLE
194           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px)
195#else         
196           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
197#endif     
198
199           if (ierr.ne.NF_NOERR) then
200              write(*,*) "***** PUT_VAR matter in write_archive"
201              write(*,*) "***** with ",nom,nf_STRERROR(ierr)
202              call abort
203           endif
204
205
206!Cas Variable 0D (scalaire dependant du temps)
207!---------------------------------------------
208
209        else if (dim.eq.0) then
210
211!         Ecriture du champs
212
213           ierr= NF_INQ_VARID(nid,nom,varid)
214           if (ierr /= NF_NOERR) then
215!  choix du nom des coordonnees
216              ierr= NF_INQ_DIMID(nid,"Time",id(1))
217
218! Creation de la variable si elle n'existait pas
219
220              write (*,*) "====================="
221              write (*,*) "creation de ",nom
222
223              call def_var(nid,nom,titre,unite,1,id,varid,ierr)
224
225           endif
226
227           corner(1)=ntime
228           edges(1)=1
229
230#ifdef NC_DOUBLE
231           ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px)
232#else
233           ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px)
234#endif
235           if (ierr.ne.NF_NOERR) then
236              write(*,*) "***** PUT_VAR matter in write_archive"
237              write(*,*) "***** with ",nom,nf_STRERROR(ierr)
238              call abort
239           endif
240
241        else
242          write(*,*) "write_archive: dim=",dim," ?!?"
243          call abort
244        endif ! of if (dim.eq.3) else if (dim.eq.-3) ....
245
246      return
247      end
248
Note: See TracBrowser for help on using the repository browser.