My Project
 All Classes Files Functions Variables Macros
grilles_gcm_netcdf_sub.F90
Go to the documentation of this file.
1 !
2 ! $Header$
3 !
4 ! This subroutine creates the file grilles_gcm.nc containg longitudes and
5 ! latitudes in degrees for grid u and v. This subroutine is called from
6 ! ce0l if grilles_gcm_netcdf=TRUE. This subroutine corresponds to the first
7 ! part in the program create_fausse_var.
8 !
9 SUBROUTINE grilles_gcm_netcdf_sub(masque,phis)
10 
11  IMPLICIT NONE
12 
13  include "dimensions.h"
14  include "paramet.h"
15  include "comconst.h"
16  include "comgeom.h"
17  include "comvert.h"
18  include "netcdf.inc"
19  include "serre.h"
20 
21 
22  REAL,DIMENSION(iip1,jjp1),INTENT(IN) :: masque ! masque terre/mer
23  REAL,DIMENSION(iip1,jjp1),INTENT(IN) :: phis ! geopotentiel au sol
24 
25  REAL temp(iim+1,jjm+1)
26  ! Attributs netcdf sortie
27  INTEGER ncid_out,rcode_out
28  INTEGER out_lonuid,out_lonvid,out_latuid,out_latvid,out_levid
29  INTEGER out_varid
30  INTEGER out_lonudim,out_lonvdim
31  INTEGER out_latudim,out_latvdim,out_dim(3)
32  INTEGER out_levdim
33 
34  INTEGER, PARAMETER :: longcles = 20
35  REAL clesphy0(longcles)
36 
37  INTEGER start(4),count(4)
38 
39  INTEGER status,i,j
40  REAL rlatudeg(jjp1),rlatvdeg(jjm),rlevdeg(llm)
41  REAL rlonudeg(iip1),rlonvdeg(iip1)
42 
43  REAL dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1)
44  REAL acoslat,dxkm,dykm,resol(iip1,jjp1)
45  REAL,DIMENSION(iip1,jjp1) :: phis_loc
46  INTEGER masque_int(iip1,jjp1)
47  INTEGER :: phis_id
48  INTEGER :: area_id
49  INTEGER :: mask_id
50 
51  rad = 6400000
52  omeg = 7.272205e-05
53  g = 9.8
54  kappa = 0.285716
55  daysec = 86400
56  cpp = 1004.70885
57 
58  preff = 101325.
59  pa= 50000.
60 
61  CALL conf_gcm( 99, .true. , clesphy0 )
62  CALL iniconst
63  CALL inigeom
64 
65  DO j=1,jjp1
66  rlatudeg(j)=rlatu(j)*180./pi
67  ENDDO
68  DO j=1,jjm
69  rlatvdeg(j)=rlatv(j)*180./pi
70  ENDDO
71 
72  DO i=1,iip1
73  rlonudeg(i)=rlonu(i)*180./pi + 360.
74  rlonvdeg(i)=rlonv(i)*180./pi + 360.
75  ENDDO
76 
77 
78  ! 2 ----- OUVERTURE DE LA SORTIE NETCDF
79  ! ---------------------------------------------------
80  ! CREATION OUTPUT
81  ! ouverture fichier netcdf de sortie out
82  status=nf_create('grilles_gcm.nc',nf_noclobber,ncid_out)
83  status=nf_def_dim(ncid_out,'lonu',iim+1,out_lonudim)
84  status=nf_def_dim(ncid_out,'lonv',iim+1,out_lonvdim)
85  status=nf_def_dim(ncid_out,'latu',jjm+1,out_latudim)
86  status=nf_def_dim(ncid_out,'latv',jjm,out_latvdim)
87 
88 
89  ! Longitudes en u
90  status=nf_def_var(ncid_out,'lonu',nf_float,1,out_lonudim, out_lonuid)
91  CALL handle_err(status)
92  status=nf_put_att_text(ncid_out,out_lonuid,'units', 12,'degrees_east')
93  status=nf_put_att_text(ncid_out,out_lonuid,'long_name',9,'Longitude en u')
94 
95  ! Longitudes en v
96  status=nf_def_var(ncid_out,'lonv',nf_float,1,out_lonvdim, out_lonvid)
97  CALL handle_err(status)
98  status=nf_put_att_text(ncid_out,out_lonvid,'units', 12,'degrees_east')
99  status=nf_put_att_text(ncid_out,out_lonvid,'long_name', 9,'Longitude en v')
100 
101  ! Latitude en u
102  status=nf_def_var(ncid_out,'latu',nf_float,1,out_latudim, out_latuid)
103  CALL handle_err(status)
104  status=nf_put_att_text(ncid_out,out_latuid,'units', 13,'degrees_north')
105  status=nf_put_att_text(ncid_out,out_latuid,'long_name', 8,'Latitude en u')
106 
107  ! Latitude en v
108  status=nf_def_var(ncid_out,'latv',nf_float,1,out_latvdim, out_latvid)
109  CALL handle_err(status)
110  status=nf_put_att_text(ncid_out,out_latvid,'units', 13,'degrees_north')
111  status=nf_put_att_text(ncid_out,out_latvid,'long_name', 8,'Latitude en v')
112 
113  ! ecriture de la grille u
114  out_dim(1)=out_lonudim
115  out_dim(2)=out_latudim
116  status=nf_def_var(ncid_out,'grille_u',nf_float,2,out_dim, out_varid)
117  CALL handle_err(status)
118  status=nf_put_att_text(ncid_out,out_varid,'units', 6,'Kelvin')
119  status=nf_put_att_text(ncid_out,out_varid,'long_name', 16,'Grille aux point u')
120 
121  ! ecriture de la grille v
122  out_dim(1)=out_lonvdim
123  out_dim(2)=out_latvdim
124  status=nf_def_var(ncid_out,'grille_v',nf_float,2,out_dim, out_varid)
125  CALL handle_err(status)
126  status=nf_put_att_text(ncid_out,out_varid,'units', 6,'Kelvin')
127  status=nf_put_att_text(ncid_out,out_varid,'long_name', 16,'Grille aux point v')
128 
129  ! ecriture de la grille u
130  out_dim(1)=out_lonvdim
131  out_dim(2)=out_latudim
132  status=nf_def_var(ncid_out,'grille_s',nf_float,2,out_dim, out_varid)
133  CALL handle_err(status)
134  status=nf_put_att_text(ncid_out,out_varid,'units', 6,'Kelvin')
135  status=nf_put_att_text(ncid_out,out_varid,'long_name',16,'Grille aux point u')
136 
137  status=nf_enddef(ncid_out)
138  ! 5) ----- FERMETURE DES FICHIERS NETCDF------------------
139  ! --------------------------------------------------------
140  ! 3-b- Ecriture de la grille pour la sortie
141  ! rajoute l'ecriture de la grille
142 
143 #ifdef NC_DOUBLE
144  status=nf_put_vara_double(ncid_out,out_lonuid,1,iim+1,rlonudeg)
145  status=nf_put_vara_double(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
146  status=nf_put_vara_double(ncid_out,out_latuid,1,jjm+1,rlatudeg)
147  status=nf_put_vara_double(ncid_out,out_latvid,1,jjm,rlatvdeg)
148 #else
149  status=nf_put_vara_real(ncid_out,out_lonuid,1,iim+1,rlonudeg)
150  status=nf_put_vara_real(ncid_out,out_lonvid,1,iim+1,rlonvdeg)
151  status=nf_put_vara_real(ncid_out,out_latuid,1,jjm+1,rlatudeg)
152  status=nf_put_vara_real(ncid_out,out_latvid,1,jjm,rlatvdeg)
153 #endif
154 
155  start(1)=1
156  start(2)=1
157  start(3)=1
158  start(4)=1
159 
160  count(1)=iim+1
161  count(2)=jjm+1
162  count(3)=1
163  count(4)=1
164 
165  DO j=1,jjm+1
166  DO i=1,iim+1
167  temp(i,j)=mod(i,2)+mod(j,2)
168  ENDDO
169  ENDDO
170 
171 #ifdef NC_DOUBLE
172  status=nf_put_vara_double(ncid_out,out_varid,start, count,temp)
173 #else
174  status=nf_put_vara_real(ncid_out,out_varid,start, count,temp)
175 #endif
176 
177  ! On re-ouvre le fichier pour rajouter 4 nouvelles variables necessaire pour INCA
178 ! lev - phis - aire - mask
179  rlevdeg(:) = presnivs
180  phis_loc(:,:) = phis(:,:)/g
181 
182 ! niveaux de pression verticaux
183  status = nf_redef(ncid_out)
184  status=nf_def_dim(ncid_out,'lev',llm,out_levdim)
185 
186 ! fields
187  out_dim(1)=out_lonvdim
188  out_dim(2)=out_latudim
189 
190  status = nf_def_var(ncid_out,'phis',nf_float,2,out_dim,phis_id)
191  CALL handle_err(status)
192  status = nf_def_var(ncid_out,'aire',nf_float,2,out_dim,area_id)
193  CALL handle_err(status)
194  status = nf_def_var(ncid_out,'mask',nf_int ,2,out_dim,mask_id)
195  CALL handle_err(status)
196 
197  status=nf_enddef(ncid_out)
198 
199  ! ecriture des variables
200 #ifdef NC_DOUBLE
201  status=nf_put_vara_double(ncid_out,out_levid,1,llm,rlevdeg)
202 #else
203  status=nf_put_vara_real(ncid_out,out_levid,1,llm,rlevdeg)
204 #endif
205 
206  start(1)=1
207  start(2)=1
208  start(3)=1
209  start(4)=0
210  count(1)=iip1
211  count(2)=jjp1
212  count(3)=1
213  count(4)=0
214 
215  status = nf_put_vara_double(ncid_out, phis_id,start,count, phis_loc)
216  status = nf_put_vara_double(ncid_out, area_id,start,count, aire)
217  masque_int(:,:) = nint(masque(:,:))
218  status = nf_put_vara_int(ncid_out, mask_id,start,count,masque_int)
219  CALL handle_err(status)
220 
221  ! fermeture du fichier netcdf
222  CALL ncclos(ncid_out,rcode_out)
223 
224 END SUBROUTINE grilles_gcm_netcdf_sub
225 
226 
227 
228 SUBROUTINE handle_err(status)
229  include "netcdf.inc"
230 
231  INTEGER status
232  IF (status.NE.nf_noerr) THEN
233  print *,nf_strerror(status)
234  CALL abort_gcm('grilles_gcm_netcdf','netcdf error',1)
235  ENDIF
236 END SUBROUTINE handle_err
237