source: LMDZ4/branches/unlabeled-1.1.1/libf/dyn3d/grilles_gcm_netcdf.F @ 5444

Last change on this file since 5444 was 524, checked in by lmdzadmin, 21 years ago

Initial revision
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.6 KB
Line 
1!
2! $Header$
3!
4c
5c
6
7      PROGRAM create_fausse_var
8C
9      IMPLICIT NONE
10C
11C
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
21c 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
57c     open(99,file='run.def',status='old',form='formatted')
58c     CALL defrun_new( 99, .TRUE.,clesphy0 )
59c     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
76         rlonvdeg(i)=rlonv(i)*180./pi
77      enddo
78
79
80      print*,'OK2'
81c  2 ----- OUVERTURE DE LA SORTIE NETCDF
82c ---------------------------------------------------
83c CREATION OUTPUT
84c 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'
95c   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
105c   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
115c   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
124c  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
133c   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
144c   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
155c   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)
169c 5) ----- FERMETURE DES FICHIERS NETCDF------------------
170c --------------------------------------------------------
171c 3-b- Ecriture de la grille pour la sortie
172c 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
211c fermeture du fichier netcdf
212        call ncclos(ncid_out,rcode_out)
213        write(*,*) 'Fermeture: ',fich_out
214
215
216      print*,'OK5'
217c   Ecriture grads
218      open (20,file='grille.dat',form='unformatted',access='direct'
219     s      ,recl=4*ip1jmp1)
220      write(20,rec=1) ((float(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1)
221      write(20,rec=2) ((float(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
224c        dlat2(j)=180.*fyprim(float(j))/pi
225      enddo
226      do i=2,iip1
227         dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi
228c        dlon2(i)=180.*fxprim(float(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
262c   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
Note: See TracBrowser for help on using the repository browser.