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