source: LMDZ.3.3/tags/IPSL-CM4_IPCC/libf/dyn3d/grilles_gcm_netcdf.F @ 601

Last change on this file since 601 was 601, checked in by (none), 19 years ago

This commit was manufactured by cvs2svn to create tag
'IPSL-CM4_IPCC'.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.1 KB
Line 
1c
2c $Header$
3c
4
5      PROGRAM create_fausse_var
6C
7      IMPLICIT NONE
8C
9C
10#include "dimensions.h"
11#include "paramet.h"
12#include "comconst.h"
13#include "comgeom.h"
14#include "comvert.h"
15
16      real temp(iim+1,jjm+1)
17#include "netcdf.inc"
18
19c Attributs netcdf sortie
20        character*64 fich_out
21        integer*4 ncid_out,rcode_out
22        integer*4 out_lonuid,out_lonvid,out_latuid,out_latvid
23        integer*4 out_varid
24        integer*4 out_lonudim,out_lonvdim
25        integer*4 out_latudim,out_latvdim,out_dim(3)
26
27      INTEGER         longcles
28      PARAMETER     ( longcles = 20 )
29      REAL  clesphy0( longcles )
30
31      integer start(4),count(4)
32
33        integer status,i,j
34        real rlatudeg(jjp1),rlatvdeg(jjm)
35        real rlonudeg(iip1),rlonvdeg(iip1)
36
37      real dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1)
38      real acoslat,dxkm,dykm,resol(iip1,jjp1)
39
40#include "serre.h"
41#include "fxyprim.h"
42
43      print*,'OK0'
44
45      rad = 6400000
46      omeg = 7.272205e-05
47      g = 9.8
48      kappa = 0.285716
49      daysec = 86400
50      cpp = 1004.70885
51
52      preff = 101325.
53      pa= 50000.
54
55      open(99,file='run.def',status='old',form='formatted')
56      CALL defrun_new( 99, .TRUE.,clesphy0 )
57      close(99)
58      CALL iniconst
59      CALL inigeom
60
61
62      print*,'OK1'
63      do j=1,jjp1
64         rlatudeg(j)=rlatu(j)*180./pi
65      enddo
66      do j=1,jjm
67         rlatvdeg(j)=rlatv(j)*180./pi
68      enddo
69
70      do i=1,iip1
71         rlonudeg(i)=rlonu(i)*180./pi
72         rlonvdeg(i)=rlonv(i)*180./pi
73      enddo
74
75
76      print*,'OK2'
77c  2 ----- OUVERTURE DE LA SORTIE NETCDF
78c ---------------------------------------------------
79c CREATION OUTPUT
80c ouverture fichier netcdf de sortie out
81        fich_out='grilles_gcm.nc'
82
83        status=NF_CREATE(fich_out,NF_NOCLOBBER,ncid_out)
84        status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim)
85        status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim)
86        status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim)
87        status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim)
88
89
90      print*,'OK3'
91c   Longitudes en u
92        print *,'OUTID: ',ncid_out
93        status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim,
94     %  out_lonuid)
95        call handle_err(status)
96        status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units',
97     %  12,'degrees_east')
98        status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name',
99     %  9,'Longitude en u')
100
101c   Longitudes en v
102        print *,'OUTID: ',ncid_out
103        status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim,
104     %  out_lonvid)
105        call handle_err(status)
106        status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units',
107     %  12,'degrees_east')
108        status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name',
109     %  9,'Longitude en v')
110
111c   Latitude en u
112        status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim,
113     %  out_latuid)
114        call handle_err(status)
115        status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units',
116     %  13,'degrees_north')
117        status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name',
118     %  8,'Latitude en u')
119
120c  Latitude en v
121        status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim,
122     %  out_latvid)
123        call handle_err(status)
124        status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units',
125     %  13,'degrees_north')
126        status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name',
127     %  8,'Latitude en v')
128
129c   ecriture de la grille u
130        out_dim(1)=out_lonudim
131        out_dim(2)=out_latudim
132        status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim,
133     %  out_varid)
134        call handle_err(status)
135        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
136     %  6,'Kelvin')
137        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
138     %  16,'Grille aux point u')
139
140c   ecriture de la grille v
141        out_dim(1)=out_lonvdim
142        out_dim(2)=out_latvdim
143        status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim,
144     %  out_varid)
145        call handle_err(status)
146        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
147     %  6,'Kelvin')
148        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
149     %  16,'Grille aux point v')
150
151c   ecriture de la grille u
152        out_dim(1)=out_lonvdim
153        out_dim(2)=out_latudim
154        status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim,
155     %  out_varid)
156        call handle_err(status)
157        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units',
158     %  6,'Kelvin')
159        status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',
160     %  16,'Grille aux point u')
161
162
163      print*,'OK4'
164        status=NF_ENDDEF(ncid_out)
165c 5) ----- FERMETURE DES FICHIERS NETCDF------------------
166c --------------------------------------------------------
167c 3-b- Ecriture de la grille pour la sortie
168c rajoute l'ecriture de la grille
169
170#ifdef NC_DOUBLE
171      status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg)
172      status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
173      status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg)
174      status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg)
175#else
176      status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg)
177      status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
178      status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg)
179      status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg)
180#endif
181
182        start(1)=1
183        start(2)=1
184        start(3)=1
185        start(4)=1
186
187        count(1)=iim+1
188        count(2)=jjm+1
189        count(3)=1
190        count(4)=1
191
192        do j=1,jjm+1
193           do i=1,iim+1
194              temp(i,j)=mod(i,2)+mod(j,2)
195           enddo
196        enddo
197
198#ifdef NC_DOUBLE
199        status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start,
200     s  count,temp)
201#else
202        status=NF_PUT_VARA_REAL(ncid_out,out_varid,start,
203     s  count,temp)
204#endif
205
206
207c fermeture du fichier netcdf
208        call ncclos(ncid_out,rcode_out)
209        write(*,*) 'Fermeture: ',fich_out
210
211
212      print*,'OK5'
213c   Ecriture grads
214      open (20,file='grille.dat',form='unformatted',access='direct'
215     s      ,recl=4*ip1jmp1)
216      write(20,rec=1) ((float(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1)
217      write(20,rec=2) ((float(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1)
218      do j=2,jjm
219         dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi
220c        dlat2(j)=180.*fyprim(float(j))/pi
221      enddo
222      do i=2,iip1
223         dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi
224c        dlon2(i)=180.*fxprim(float(i))/pi
225      enddo
226      do j=2,jjm
227         dykm=(rlatv(j)-rlatv(j-1))*6400.
228         acoslat=6400.*cos(rlatu(j))
229         do i=2,iip1
230            dxkm=acoslat*(rlonu(i)-rlonu(i-1))
231            resol(i,j)=sqrt(dykm*dykm+dxkm*dxkm)
232         enddo
233         resol(1,j)=resol(iip1,j)
234      enddo
235      write(20,rec=3) resol
236      dlon1(1)=dlon1(iip1)
237      dlon2(1)=dlon2(iip1)
238      write(20,rec=4) ((dlon1(i),i=1,iip1),j=1,jjp1)
239      write(20,rec=5) ((dlon2(i),i=1,iip1),j=1,jjp1)
240      write(20,rec=6) ((dlat1(j),i=1,iip1),j=1,jjp1)
241      write(20,rec=7) ((dlat2(j),i=1,iip1),j=1,jjp1)
242       
243      open (21,file='grille.ctl',form='formatted')
244
245c   WARNING! on reecrase le fichier .ctl a chaque ecriture
246      write(21,'(a5,1x,a40)')
247     &       'DSET ','^grille.dat'
248
249      write(21,'(a12)') 'UNDEF 1.0E30'
250      write(21,'(a5,1x,a40)') 'TITLE ','grille'
251      call formcoord(21,iip1,rlonv,180./pi,.false.,'XDEF')
252      call formcoord(21,jjp1,rlatu,180./pi,.true.,'YDEF')
253      call formcoord(21,1,0.,1.,.false.,'ZDEF')
254      write(21,'(a4,i10,a30)')
255     &       'TDEF ',1,' LINEAR 23OCT1994 3hr '
256      write(21,'(a4,2x,i5)') 'VARS',7
257      write(21,'(a18)') 'grille 0 99 grille'
258      write(21,'(a18)') 'gril   0 99 gril  '
259      write(21,'(a29)') 'resol   0 99 resolution (km)  '
260      write(21,'(a18)') 'dlon1  0 99 dlon1 '
261      write(21,'(a18)') 'dlon2  0 99 dlon2 '
262      write(21,'(a18)') 'dlat1  0 99 dlat1 '
263      write(21,'(a18)') 'dlat2  0 99 dlat2 '
264      write(21,'(a7)') 'ENDVARS'
265
266
267
268
269
270      print*,'OK6'
271        end
272
273
274
275        subroutine handle_err(status)
276#include "netcdf.inc"
277
278
279        integer status
280        print *,'handle code err: ',NF_NOERR
281        IF (status.NE.nf_noerr) THEN
282                print *,NF_STRERROR(status)
283                stop 'stopped'
284        ENDIF
285        END
286
Note: See TracBrowser for help on using the repository browser.