Context Navigation

limit_netcdf.F @ 324

Last change on this file since 324 was 320, checked in by lmdzadmin, 24 years ago
Adaptation à la version couplée LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 28.6 KB

Rev	Line
[259]	1	C
	2	C $Header$
	3	C
[320]	4	SUBROUTINE limit_netcdf ( interbar, extrap, oldice, masque )
[259]	5	c
	6	IMPLICIT none
	7	c
	8	c-------------------------------------------------------------
	9	C Author : L. Fairhead
	10	C Date : 27/01/94
	11	C Objet : Construction des fichiers de conditions aux limites
	12	C pour le nouveau
	13	C modele a partir de fichiers de climatologie. Les deux
	14	C grilles doivent etre regulieres
	15	c
	16	c Modifie par z.x.li (le23mars1994)
	17	c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999
	18	c pour lecture netcdf dans LMDZ.3.3
	19	c Modifie par P;Le Van , juillet 2001
	20	c-------------------------------------------------------------
	21	c
	22	#include "dimensions.h"
	23	#include "paramet.h"
	24	#include "control.h"
	25	#include "logic.h"
	26	#include "netcdf.inc"
	27	#include "comvert.h"
	28	#include "comgeom2.h"
	29	#include "comconst.h"
[320]	30	#include "dimphy.h"
[259]	31	c
	32	c-----------------------------------------------------------------------
	33	LOGICAL interbar, extrap, oldice
	34
	35	INTEGER KIDIA, KFDIA, KLON, KLEV
	36	c-----------------------------------------------------------------------
	37	REAL phy_nat(klon,360), phy_nat0(klon)
	38	REAL phy_alb(klon,360)
	39	REAL phy_sst(klon,360)
	40	REAL phy_bil(klon,360)
	41	REAL phy_rug(klon,360)
	42	REAL phy_ice(klon,360)
	43	c
	44	REAL masque(iip1,jjp1)
	45	REAL mask(iim,jjp1)
	46
	47	C Declarations pour le champ de depart
	48	INTEGER imdep, jmdep,lmdep
	49	INTEGER tbid
	50	PARAMETER ( tbid = 60 ) ! >52 semaines
	51	REAL timecoord(tbid)
	52	c
	53	REAL , ALLOCATABLE :: dlon_msk(:), dlat_msk(:)
	54	REAL , ALLOCATABLE :: lonmsk_ini(:), latmsk_ini(:)
	55	REAL , ALLOCATABLE :: dlon(:), dlat(:)
	56	REAL , ALLOCATABLE :: dlon_ini(:), dlat_ini(:)
	57	REAL , ALLOCATABLE :: champ_msk(:), champ(:)
	58	REAL , ALLOCATABLE :: work(:,:)
	59
	60	CHARACTER*25 title
	61
	62	C Declarations pour le champ interpole 2D
	63	REAL champint(iim,jjp1)
	64	real chmin,chmax
	65
	66	C Declarations pour le champ interpole 3D
	67	REAL champtime(iim,jjp1,tbid)
	68	REAL timeyear(tbid)
	69	REAL champan(iip1,jjp1,366)
	70
	71	C Declarations pour l'inteprolation verticale
	72	REAL ax(tbid), ay(tbid)
	73	REAL by
	74	REAL yder(tbid)
	75
	76
	77	INTEGER ierr
	78	INTEGER dimfirst(3)
	79	INTEGER dimlast(3)
	80	c
	81	INTEGER nid, ndim, ntim
	82	INTEGER dims(2), debut(2), epais(2)
	83	INTEGER id_tim
	84	INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB
	85
	86	INTEGER i, j, k, l
	87	c Diverses variables locales
	88	REAL time
	89
	90	INTEGER longcles
	91	PARAMETER ( longcles = 20 )
	92	REAL clesphy0 ( longcles )
	93	#include "serre.h"
	94	INTEGER ncid,varid,ndimid(4),dimid
	95	character*30 namedim
	96
	97	pi = 4. * ATAN(1.)
	98	rad = 6 371 229.
	99	omeg = 4.* ASIN(1.)/(24.*3600.)
	100	g = 9.8
	101	daysec = 86400.
	102	kappa = 0.2857143
	103	cpp = 1004.70885
	104	dtvr = daysec/FLOAT(day_step)
	105	c
	106	C Traitement du relief au sol
	107	c
	108	write(,) 'Traitement du relief au sol pour fabriquer masque'
	109	ierr = NF_OPEN('Relief.nc', NF_NOWRITE, ncid)
	110
	111	if (ierr.ne.0) then
	112	print *, NF_STRERROR(ierr)
	113	STOP
	114	ENDIF
	115
	116	ierr = NF_INQ_VARID(ncid,'RELIEF',varid)
	117	if (ierr.ne.0) then
	118	print *, NF_STRERROR(ierr)
	119	STOP
	120	ENDIF
	121	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
	122	if (ierr.ne.0) then
	123	print *, NF_STRERROR(ierr)
	124	STOP
	125	ENDIF
	126	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
	127	if (ierr.ne.0) then
	128	print *, NF_STRERROR(ierr)
	129	STOP
	130	ENDIF
	131	print*,'variable ', namedim, 'dimension ', imdep
	132	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	133	if (ierr.ne.0) then
	134	print *, NF_STRERROR(ierr)
	135	STOP
	136	ENDIF
	137
	138	ALLOCATE( lonmsk_ini(imdep) )
	139	ALLOCATE( dlon_msk(imdep) )
	140
	141	#ifdef NC_DOUBLE
	142	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,lonmsk_ini)
	143	#else
	144	ierr = NF_GET_VAR_REAL(ncid,dimid,lonmsk_ini)
	145	#endif
	146
	147	c
	148	if (ierr.ne.0) then
	149	print *, NF_STRERROR(ierr)
	150	STOP
	151	ENDIF
	152	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
	153	if (ierr.ne.0) then
	154	print *, NF_STRERROR(ierr)
	155	STOP
	156	ENDIF
	157	print*,'variable ', namedim, 'dimension ', jmdep
	158	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	159	if (ierr.ne.0) then
	160	print *, NF_STRERROR(ierr)
	161	STOP
	162	ENDIF
	163
	164	ALLOCATE( latmsk_ini(jmdep) )
	165	ALLOCATE( dlat_msk(jmdep) )
	166	ALLOCATE( champ_msk(imdep*jmdep) )
	167
	168	#ifdef NC_DOUBLE
	169	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,latmsk_ini)
	170	#else
	171	ierr = NF_GET_VAR_REAL(ncid,dimid,latmsk_ini)
	172	#endif
	173	c
	174	if (ierr.ne.0) then
	175	print *, NF_STRERROR(ierr)
	176	STOP
	177	ENDIF
	178	#ifdef NC_DOUBLE
	179	ierr = NF_GET_VAR_DOUBLE(ncid,varid,champ_msk)
	180	#else
	181	ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk)
	182	#endif
	183	c
	184	if (ierr.ne.0) then
	185	print *, NF_STRERROR(ierr)
	186	STOP
	187	ENDIF
	188	c
	189	title='RELIEF'
	190
	191	CALL conf_dat2d(title,imdep, jmdep, lonmsk_ini, latmsk_ini,
	192	. dlon_msk, dlat_msk, champ_msk, interbar )
	193
	194	CALL mask_c_o(imdep, jmdep, dlon_msk, dlat_msk,champ_msk,
	195	. iim, jjp1, rlonv, rlatu, champint)
[320]	196	c CALL gr_int_dyn(champint, masque, iim, jjp1)
	197	c DO i = 1, iim
	198	c masque(i,1) = FLOAT(NINT(masque(i,1)))
	199	c masque(i,jjp1) = FLOAT(NINT(masque(i,jjp1)))
	200	c ENDDO
[259]	201	DO i = 1, iim
	202	DO j = 1, jjp1
	203	mask(i,j) = champint(i,j)
	204	ENDDO
	205	ENDDO
[320]	206	c CALL gr_dyn_fi(1, iip1, jjp1, klon, masque, phy_nat0)
[259]	207	ierr = NF_CLOSE(ncid)
	208	c
	209	c
	210	C Traitement de la rugosite
	211	c
	212	PRINT*, 'Traitement de la rugosite'
	213	ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid)
	214	if (ierr.ne.0) then
	215	print *, NF_STRERROR(ierr)
	216	STOP
	217	ENDIF
	218
	219	ierr = NF_INQ_VARID(ncid,'RUGOS',varid)
	220	if (ierr.ne.0) then
	221	print *, NF_STRERROR(ierr)
	222	STOP
	223	ENDIF
	224	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
	225	if (ierr.ne.0) then
	226	print *, NF_STRERROR(ierr)
	227	STOP
	228	ENDIF
	229	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
	230	if (ierr.ne.0) then
	231	print *, NF_STRERROR(ierr)
	232	STOP
	233	ENDIF
	234	print*,'variable ', namedim, 'dimension ', imdep
	235	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	236	if (ierr.ne.0) then
	237	print *, NF_STRERROR(ierr)
	238	STOP
	239	ENDIF
	240
	241	ALLOCATE( dlon_ini(imdep) )
	242	ALLOCATE( dlon(imdep) )
	243
	244	#ifdef NC_DOUBLE
	245	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
	246	#else
	247	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
	248	#endif
	249	if (ierr.ne.0) then
	250	print *, NF_STRERROR(ierr)
	251	STOP
	252	ENDIF
	253	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
	254	if (ierr.ne.0) then
	255	print *, NF_STRERROR(ierr)
	256	STOP
	257	ENDIF
	258	print*,'variable ', namedim, 'dimension ', jmdep
	259	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	260	if (ierr.ne.0) then
	261	print *, NF_STRERROR(ierr)
	262	STOP
	263	ENDIF
	264
	265	ALLOCATE( dlat_ini(jmdep) )
	266	ALLOCATE( dlat(jmdep) )
	267
	268	#ifdef NC_DOUBLE
	269	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
	270	#else
	271	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
	272	#endif
	273	if (ierr.ne.0) then
	274	print *, NF_STRERROR(ierr)
	275	STOP
	276	ENDIF
	277	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
	278	if (ierr.ne.0) then
	279	print *, NF_STRERROR(ierr)
	280	STOP
	281	ENDIF
	282	print*,'variable ', namedim, 'dimension ', lmdep
	283	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	284	if (ierr.ne.0) then
	285	print *, NF_STRERROR(ierr)
	286	STOP
	287	ENDIF
	288	#ifdef NC_DOUBLE
	289	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
	290	#else
	291	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
	292	#endif
	293	if (ierr.ne.0) then
	294	print *, NF_STRERROR(ierr)
	295	STOP
	296	ENDIF
	297	c
	298	ALLOCATE( champ(imdep*jmdep) )
	299
	300	DO 200 l = 1, lmdep
	301	dimfirst(1) = 1
	302	dimfirst(2) = 1
	303	dimfirst(3) = l
	304	c
	305	dimlast(1) = imdep
	306	dimlast(2) = jmdep
	307	dimlast(3) = 1
	308	c
	309	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
	310	print*,dimfirst,dimlast
	311	#ifdef NC_DOUBLE
	312	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
	313	#else
	314	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
	315	#endif
	316	if (ierr.ne.0) then
	317	print *, NF_STRERROR(ierr)
	318	STOP
	319	ENDIF
	320
	321	title = 'Rugosite Amip '
	322	c
	323	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
	324	. dlon, dlat, champ, interbar )
	325
	326	IF ( interbar ) THEN
	327	DO j = 1, imdep * jmdep
	328	champ(j) = LOG(champ(j))
	329	ENDDO
	330
	331	IF( l.EQ.1 ) THEN
	332	WRITE(6,*) '-------------------------------------------------',
	333	,'------------------------'
	334	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
	335	, ' pour la rugosite $$$ '
	336	WRITE(6,*) '-------------------------------------------------',
	337	,'------------------------'
	338	ENDIF
	339	CALL inter_barxy ( imdep,jmdep -1,dlon,dlat,champ ,
	340	, iim,jjm,rlonu,rlatv, jjp1,champint )
	341	DO j=1,jjp1
	342	DO i=1,iim
	343	champint(i,j)=EXP(champint(i,j))
	344	ENDDO
	345	ENDDO
	346
	347	DO j = 1, jjp1
	348	DO i = 1, iim
	349	IF(NINT(mask(i,j)).NE.1) THEN
	350	champint( i,j ) = 0.001
	351	ENDIF
	352	ENDDO
	353	ENDDO
	354	ELSE
	355	CALL rugosite(imdep, jmdep, dlon, dlat, champ,
	356	. iim, jjp1, rlonv, rlatu, champint, mask)
	357	ENDIF
	358	DO j = 1,jjp1
	359	DO i = 1, iim
	360	champtime (i,j,l) = champint(i,j)
	361	ENDDO
	362	ENDDO
	363	200 CONTINUE
	364	c
	365	DO l = 1, lmdep
	366	timeyear(l) = timecoord(l)
	367	ENDDO
	368
	369	PRINT 222, timeyear
	370	222 FORMAT(2x,' Time year ',10f6.1)
	371	c
	372
	373	PRINT*, 'Interpolation temporelle dans l annee'
	374
	375	DO j = 1, jjp1
	376	DO i = 1, iim
	377	DO l = 1, lmdep
	378	ax(l) = timeyear(l)
	379	ay(l) = champtime (i,j,l)
	380	ENDDO
	381	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
	382	DO k = 1, 360
	383	time = FLOAT(k-1)
	384	CALL SPLINT(ax,ay,yder,lmdep,time,by)
	385	champan(i,j,k) = by
	386	ENDDO
	387	ENDDO
	388	ENDDO
	389	DO k = 1, 360
	390	DO j = 1, jjp1
	391	champan(iip1,j,k) = champan(1,j,k)
	392	ENDDO
	393	IF ( k.EQ.10 ) THEN
	394	DO j = 1, jjp1
	395	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
	396	PRINT *,' Rugosite au temps 10 ', chmin,chmax,j
	397	ENDDO
	398	ENDIF
	399	ENDDO
	400	c
	401	DO k = 1, 360
	402	CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k))
	403	ENDDO
	404	c
	405	ierr = NF_CLOSE(ncid)
	406
	407	DEALLOCATE( dlon )
	408	DEALLOCATE( dlon_ini )
	409	DEALLOCATE( dlat )
	410	DEALLOCATE( dlat_ini )
	411	DEALLOCATE( champ )
	412	c
	413	c
	414	C Traitement de la glace oceanique
	415	c
	416	PRINT*, 'Traitement de la glace oceanique'
	417	ierr = NF_OPEN('AMIP.nc', NF_NOWRITE, ncid)
	418	if (ierr.ne.0) then
	419	print *, NF_STRERROR(ierr)
	420	STOP
	421	ENDIF
	422
	423	ierr = NF_INQ_VARID(ncid,'SEA_ICE',varid)
	424	if (ierr.ne.0) then
	425	print *, NF_STRERROR(ierr)
	426	STOP
	427	ENDIF
	428	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
	429	if (ierr.ne.0) then
	430	print *, NF_STRERROR(ierr)
	431	STOP
	432	ENDIF
	433	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
	434	if (ierr.ne.0) then
	435	print *, NF_STRERROR(ierr)
	436	STOP
	437	ENDIF
	438	print*,'variable ', namedim, 'dimension ', imdep
	439	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	440	if (ierr.ne.0) then
	441	print *, NF_STRERROR(ierr)
	442	STOP
	443	ENDIF
	444
	445	ALLOCATE ( dlon_ini(imdep) )
	446	ALLOCATE ( dlon(imdep) )
	447
	448	#ifdef NC_DOUBLE
	449	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
	450	#else
	451	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
	452	#endif
	453	if (ierr.ne.0) then
	454	print *, NF_STRERROR(ierr)
	455	STOP
	456	ENDIF
	457	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
	458	if (ierr.ne.0) then
	459	print *, NF_STRERROR(ierr)
	460	STOP
	461	ENDIF
	462	print*,'variable ', namedim, jmdep
	463	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	464	if (ierr.ne.0) then
	465	print *, NF_STRERROR(ierr)
	466	STOP
	467	ENDIF
	468
	469	ALLOCATE ( dlat_ini(jmdep) )
	470	ALLOCATE ( dlat(jmdep) )
	471
	472	#ifdef NC_DOUBLE
	473	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
	474	#else
	475	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
	476	#endif
	477	if (ierr.ne.0) then
	478	print *, NF_STRERROR(ierr)
	479	STOP
	480	ENDIF
	481	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
	482	if (ierr.ne.0) then
	483	print *, NF_STRERROR(ierr)
	484	STOP
	485	ENDIF
	486	print*,'variable ', namedim, lmdep
	487	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	488	if (ierr.ne.0) then
	489	print *, NF_STRERROR(ierr)
	490	STOP
	491	ENDIF
	492	#ifdef NC_DOUBLE
	493	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
	494	#else
	495	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
	496	#endif
	497	if (ierr.ne.0) then
	498	print *, NF_STRERROR(ierr)
	499	STOP
	500	ENDIF
	501	c
	502	ALLOCATE ( champ(imdep*jmdep) )
	503
	504	DO l = 1, lmdep
	505	dimfirst(1) = 1
	506	dimfirst(2) = 1
	507	dimfirst(3) = l
	508	c
	509	dimlast(1) = imdep
	510	dimlast(2) = jmdep
	511	dimlast(3) = 1
	512	c
	513	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
	514	#ifdef NC_DOUBLE
	515	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
	516	#else
	517	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
	518	#endif
	519	if (ierr.ne.0) then
	520	print *, NF_STRERROR(ierr)
	521	STOP
	522	ENDIF
	523
	524	title = 'Sea-ice Amip '
	525	c
	526	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
	527	. dlon, dlat, champ, interbar )
	528	c
	529	IF( oldice ) THEN
	530	CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
	531	. iim, jjp1, rlonv, rlatu, champint )
	532	ELSEIF ( interbar ) THEN
	533	IF( l.EQ.1 ) THEN
	534	WRITE(6,*) '-------------------------------------------------',
	535	,'------------------------'
	536	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
	537	, ' pour Sea-ice Amip $$$ '
	538	WRITE(6,*) '-------------------------------------------------',
	539	,'------------------------'
	540	ENDIF
	541
	542	CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
	543	, champ, iim, jjm, rlonu, rlatv, jjp1, champint )
	544	ELSE
	545	CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
	546	. iim, jjp1, rlonv, rlatu, champint )
	547	ENDIF
	548	DO j = 1,jjp1
	549	DO i = 1, iim
	550	champtime (i,j,l) = champint(i,j)
	551	ENDDO
	552	ENDDO
	553	ENDDO
	554	c
	555	DO l = 1, lmdep
	556	timeyear(l) = timecoord(l)
	557	ENDDO
	558	PRINT 222, timeyear
	559	c
	560	PRINT*, 'Interpolation temporelle'
	561	DO j = 1, jjp1
	562	DO i = 1, iim
	563	DO l = 1, lmdep
	564	ax(l) = timeyear(l)
	565	ay(l) = champtime (i,j,l)
	566	ENDDO
	567	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
	568	DO k = 1, 360
	569	time = FLOAT(k-1)
	570	CALL SPLINT(ax,ay,yder,lmdep,time,by)
	571	champan(i,j,k) = by
	572	ENDDO
	573	ENDDO
	574	ENDDO
	575	DO k = 1, 360
	576	DO j = 1, jjp1
	577	champan(iip1, j, k) = champan(1, j, k)
	578	ENDDO
	579	IF ( k.EQ.10 ) THEN
	580	DO j = 1, jjp1
	581	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
	582	PRINT *,' Sea ice au temps 10 ', chmin,chmax,j
	583	ENDDO
	584	ENDIF
	585	ENDDO
	586	c
	587
	588	DO k = 1, 360
	589	CALL gr_dyn_fi(1, iip1, jjp1, klon,
	590	. champan(1,1,k), phy_ice(1,k))
	591	DO i = 1, klon
[320]	592	phy_nat(i,k) = zmasq(i)
[259]	593	IF ( (phy_ice(i,k) - 0.5).GE.1.e-5 ) THEN
[320]	594	IF (NINT(zmasq(i)).EQ.0) THEN
[259]	595	phy_nat(i,k) = 3.0
	596	ELSE
	597	phy_nat(i,k) = 2.0
	598	ENDIF
	599	ENDIF
	600	IF( NINT(phy_nat(i,k)).EQ.0 ) THEN
	601	IF ( phy_rug(i,k).NE.0.001 ) phy_rug(i,k) = 0.001
	602	ENDIF
	603	ENDDO
	604
	605	ENDDO
	606	c
	607
	608	ierr = NF_CLOSE(ncid)
	609	c
	610	DEALLOCATE( dlon )
	611	DEALLOCATE( dlon_ini )
	612	DEALLOCATE( dlat )
	613	DEALLOCATE( dlat_ini )
	614	DEALLOCATE( champ )
	615
	616	477 continue
	617	c
	618	C Traitement de la sst
	619	c
	620	PRINT*, 'Traitement de la sst'
	621	ierr = NF_OPEN('AMIP.nc', NF_NOWRITE, ncid)
	622	if (ierr.ne.0) then
	623	print *, NF_STRERROR(ierr)
	624	STOP
	625	ENDIF
	626
	627	ierr = NF_INQ_VARID(ncid,'SST',varid)
	628	if (ierr.ne.0) then
	629	print *, NF_STRERROR(ierr)
	630	STOP
	631	ENDIF
	632	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
	633	if (ierr.ne.0) then
	634	print *, NF_STRERROR(ierr)
	635	STOP
	636	ENDIF
	637	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
	638	if (ierr.ne.0) then
	639	print *, NF_STRERROR(ierr)
	640	STOP
	641	ENDIF
	642	print*,'variable SST ', namedim,'dimension ', imdep
	643	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	644	if (ierr.ne.0) then
	645	print *, NF_STRERROR(ierr)
	646	STOP
	647	ENDIF
	648
	649	ALLOCATE( dlon_ini(imdep) )
	650	ALLOCATE( dlon(imdep) )
	651
	652	#ifdef NC_DOUBLE
	653	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
	654	#else
	655	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
	656	#endif
	657
	658	if (ierr.ne.0) then
	659	print *, NF_STRERROR(ierr)
	660	STOP
	661	ENDIF
	662	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
	663	if (ierr.ne.0) then
	664	print *, NF_STRERROR(ierr)
	665	STOP
	666	ENDIF
	667	print*,'variable SST ', namedim, 'dimension ', jmdep
	668	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	669	if (ierr.ne.0) then
	670	print *, NF_STRERROR(ierr)
	671	STOP
	672	ENDIF
	673
	674	ALLOCATE( dlat_ini(jmdep) )
	675	ALLOCATE( dlat(jmdep) )
	676
	677	#ifdef NC_DOUBLE
	678	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
	679	#else
	680	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
	681	#endif
	682	if (ierr.ne.0) then
	683	print *, NF_STRERROR(ierr)
	684	STOP
	685	ENDIF
	686	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
	687	if (ierr.ne.0) then
	688	print *, NF_STRERROR(ierr)
	689	STOP
	690	ENDIF
	691	print*,'variable ', namedim, 'dimension ', lmdep
	692	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	693	if (ierr.ne.0) then
	694	print *, NF_STRERROR(ierr)
	695	STOP
	696	ENDIF
	697	#ifdef NC_DOUBLE
	698	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
	699	#else
	700	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
	701	#endif
	702	if (ierr.ne.0) then
	703	print *, NF_STRERROR(ierr)
	704	STOP
	705	ENDIF
	706
	707	ALLOCATE( champ(imdep*jmdep) )
	708	IF( extrap ) THEN
	709	ALLOCATE ( work(imdep,jmdep) )
	710	ENDIF
	711	c
	712	DO l = 1, lmdep
	713	dimfirst(1) = 1
	714	dimfirst(2) = 1
	715	dimfirst(3) = l
	716	c
	717	dimlast(1) = imdep
	718	dimlast(2) = jmdep
	719	dimlast(3) = 1
	720	c
	721	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
	722	#ifdef NC_DOUBLE
	723	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
	724	#else
	725	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
	726	#endif
	727	if (ierr.ne.0) then
	728	print *, NF_STRERROR(ierr)
	729	STOP
	730	ENDIF
	731
	732	title='Sst Amip'
	733	c
	734	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
	735	. dlon, dlat, champ, interbar )
	736	IF ( extrap ) THEN
	737	CALL extrapol(champ, imdep, jmdep, 999999.,.TRUE.,.TRUE.,2,work)
	738	ENDIF
	739	c
	740
	741	IF ( interbar ) THEN
	742	IF( l.EQ.1 ) THEN
	743	WRITE(6,*) '-------------------------------------------------',
	744	,'------------------------'
	745	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
	746	, ' pour la Sst Amip $$$ '
	747	WRITE(6,*) '-------------------------------------------------',
	748	,'------------------------'
	749	ENDIF
	750	CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
	751	, champ, iim, jjm, rlonu, rlatv, jjp1, champint )
	752	ELSE
	753	CALL grille_m(imdep, jmdep, dlon, dlat, champ,
	754	. iim, jjp1, rlonv, rlatu, champint )
	755	ENDIF
	756
	757	DO j = 1,jjp1
	758	DO i = 1, iim
	759	champtime (i,j,l) = champint(i,j)
	760	ENDDO
	761	ENDDO
	762	ENDDO
	763	c
	764	DO l = 1, lmdep
	765	timeyear(l) = timecoord(l)
	766	ENDDO
	767	print 222, timeyear
	768	c
	769	C interpolation temporelle
	770	DO j = 1, jjp1
	771	DO i = 1, iim
	772	DO l = 1, lmdep
	773	ax(l) = timeyear(l)
	774	ay(l) = champtime (i,j,l)
	775	ENDDO
	776	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
	777	DO k = 1, 360
	778	time = FLOAT(k-1)
	779	CALL SPLINT(ax,ay,yder,lmdep,time,by)
	780	champan(i,j,k) = by
	781	ENDDO
	782	ENDDO
	783	ENDDO
	784	DO k = 1, 360
	785	DO j = 1, jjp1
	786	champan(iip1,j,k) = champan(1,j,k)
	787	ENDDO
	788	IF ( k.EQ.10 ) THEN
	789	DO j = 1, jjp1
	790	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
	791	PRINT *,' SST au temps 10 ', chmin,chmax,j
	792	ENDDO
	793	ENDIF
	794	ENDDO
	795	c
	796	DO k = 1, 360
	797	CALL gr_dyn_fi(1, iip1, jjp1, klon,
	798	. champan(1,1,k), phy_sst(1,k))
	799	ENDDO
	800	c
	801	ierr = NF_CLOSE(ncid)
	802	c
	803	DEALLOCATE( dlon )
	804	DEALLOCATE( dlon_ini )
	805	DEALLOCATE( dlat )
	806	DEALLOCATE( dlat_ini )
	807	DEALLOCATE( champ )
	808	c
	809	C Traitement de l'albedo
	810	c
	811	PRINT*, 'Traitement de l albedo'
	812	ierr = NF_OPEN('Albedo.nc', NF_NOWRITE, ncid)
	813	if (ierr.ne.0) then
	814	print *, NF_STRERROR(ierr)
	815	STOP
	816	ENDIF
	817	ierr = NF_INQ_VARID(ncid,'ALBEDO',varid)
	818	if (ierr.ne.0) then
	819	print *, NF_STRERROR(ierr)
	820	STOP
	821	ENDIF
	822	ierr = NF_INQ_VARDIMID (ncid,varid,ndimid)
	823	if (ierr.ne.0) then
	824	print *, NF_STRERROR(ierr)
	825	STOP
	826	ENDIF
	827	ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep)
	828	if (ierr.ne.0) then
	829	print *, NF_STRERROR(ierr)
	830	STOP
	831	ENDIF
	832	print*,'variable ', namedim, 'dimension ', imdep
	833	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	834	if (ierr.ne.0) then
	835	print *, NF_STRERROR(ierr)
	836	STOP
	837	ENDIF
	838
	839	ALLOCATE ( dlon_ini(imdep) )
	840	ALLOCATE ( dlon(imdep) )
	841
	842	#ifdef NC_DOUBLE
	843	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini)
	844	#else
	845	ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini)
	846	#endif
	847	if (ierr.ne.0) then
	848	print *, NF_STRERROR(ierr)
	849	STOP
	850	ENDIF
	851	ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep)
	852	if (ierr.ne.0) then
	853	print *, NF_STRERROR(ierr)
	854	STOP
	855	ENDIF
	856	print*,'variable ', namedim, 'dimension ', jmdep
	857	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	858	if (ierr.ne.0) then
	859	print *, NF_STRERROR(ierr)
	860	STOP
	861	ENDIF
	862
	863	ALLOCATE ( dlat_ini(jmdep) )
	864	ALLOCATE ( dlat(jmdep) )
	865
	866	#ifdef NC_DOUBLE
	867	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini)
	868	#else
	869	ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini)
	870	#endif
	871	if (ierr.ne.0) then
	872	print *, NF_STRERROR(ierr)
	873	STOP
	874	ENDIF
	875	ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep)
	876	if (ierr.ne.0) then
	877	print *, NF_STRERROR(ierr)
	878	STOP
	879	ENDIF
	880	print*,'variable ', namedim, 'dimension ', lmdep
	881	ierr = NF_INQ_VARID(ncid,namedim,dimid)
	882	if (ierr.ne.0) then
	883	print *, NF_STRERROR(ierr)
	884	STOP
	885	ENDIF
	886	#ifdef NC_DOUBLE
	887	ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord)
	888	#else
	889	ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord)
	890	#endif
	891	if (ierr.ne.0) then
	892	print *, NF_STRERROR(ierr)
	893	STOP
	894	ENDIF
	895	c
	896	ALLOCATE ( champ(imdep*jmdep) )
	897
	898	DO l = 1, lmdep
	899	dimfirst(1) = 1
	900	dimfirst(2) = 1
	901	dimfirst(3) = l
	902	c
	903	dimlast(1) = imdep
	904	dimlast(2) = jmdep
	905	dimlast(3) = 1
	906	c
	907	PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
	908	#ifdef NC_DOUBLE
	909	ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ)
	910	#else
	911	ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ)
	912	#endif
	913	if (ierr.ne.0) then
	914	print *, NF_STRERROR(ierr)
	915	STOP
	916	ENDIF
	917
	918	title='Albedo Amip'
	919	c
	920	CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini,
	921	. dlon, dlat, champ, interbar )
	922	c
	923	c
	924	IF ( interbar ) THEN
	925	IF( l.EQ.1 ) THEN
	926	WRITE(6,*) '-------------------------------------------------',
	927	,'------------------------'
	928	WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ',
	929	, ' pour l Albedo Amip $$$ '
	930	WRITE(6,*) '-------------------------------------------------',
	931	,'------------------------'
	932	ENDIF
	933
	934	CALL inter_barxy ( imdep,jmdep -1,dlon, dlat ,
	935	, champ, iim, jjm, rlonu, rlatv, jjp1, champint )
	936	ELSE
	937	CALL grille_m(imdep, jmdep, dlon, dlat, champ,
	938	. iim, jjp1, rlonv, rlatu, champint )
	939	ENDIF
	940	c
	941	DO j = 1,jjp1
	942	DO i = 1, iim
	943	champtime (i, j, l) = champint(i, j)
	944	ENDDO
	945	ENDDO
	946	ENDDO
	947	c
	948	DO l = 1, lmdep
	949	timeyear(l) = timecoord(l)
	950	ENDDO
	951	print 222, timeyear
	952	c
	953	C interpolation temporelle
	954	DO j = 1, jjp1
	955	DO i = 1, iim
	956	DO l = 1, lmdep
	957	ax(l) = timeyear(l)
	958	ay(l) = champtime (i, j, l)
	959	ENDDO
	960	CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
	961	DO k = 1, 360
	962	time = FLOAT(k-1)
	963	CALL SPLINT(ax,ay,yder,lmdep,time,by)
	964	champan(i,j,k) = by
	965	ENDDO
	966	ENDDO
	967	ENDDO
	968	DO k = 1, 360
	969	DO j = 1, jjp1
	970	champan(iip1, j, k) = champan(1, j, k)
	971	ENDDO
	972	IF ( k.EQ.10 ) THEN
	973	DO j = 1, jjp1
	974	CALL minmax( iip1,champan(1,j,10),chmin,chmax )
	975	PRINT *,' Albedo au temps 10 ', chmin,chmax,j
	976	ENDDO
	977	ENDIF
	978	ENDDO
	979	c
	980	DO k = 1, 360
	981	CALL gr_dyn_fi(1, iip1, jjp1, klon,
	982	. champan(1,1,k), phy_alb(1,k))
	983	ENDDO
	984	c
	985	ierr = NF_CLOSE(ncid)
	986	c
	987	c
	988	DO k = 1, 360
	989	DO i = 1, klon
	990	phy_bil(i,k) = 0.0
	991	ENDDO
	992	ENDDO
	993	c
	994	PRINT*, 'Ecriture du fichier limit'
	995	c
	996	ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid)
	997	c
	998	ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30,
	999	. "Fichier conditions aux limites")
	1000	ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
	1001	ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim)
	1002	c
	1003	dims(1) = ndim
	1004	dims(2) = ntim
	1005	c
	1006	ccc ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim)
	1007	ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim)
	1008	ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17,
	1009	. "Jour dans l annee")
	1010	ccc ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT)
	1011	ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT)
	1012	ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23,
	1013	. "Nature du sol (0,1,2,3)")
	1014	ccc ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST)
	1015	ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST)
	1016	ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35,
	1017	. "Temperature superficielle de la mer")
	1018	ccc ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS)
	1019	ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS)
	1020	ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32,
	1021	. "Reference flux de chaleur au sol")
	1022	ccc ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB)
	1023	ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB)
	1024	ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19,
	1025	. "Albedo a la surface")
	1026	ccc ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG)
	1027	ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
	1028	ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,
	1029	. "Rugosite")
	1030	c
	1031	ierr = NF_ENDDEF(nid)
	1032	c
	1033	DO k = 1, 360
	1034	c
	1035	debut(1) = 1
	1036	debut(2) = k
	1037	epais(1) = klon
	1038	epais(2) = 1
	1039	c
	1040	#ifdef NC_DOUBLE
	1041	ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k))
	1042	ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais,phy_nat(1,k))
	1043	ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k))
	1044	ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k))
	1045	ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k))
	1046	ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k))
	1047	#else
	1048	ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k))
	1049	ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais,phy_nat(1,k))
	1050	ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k))
	1051	ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k))
	1052	ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k))
	1053	ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k))
	1054	#endif
	1055	c
	1056	ENDDO
	1057	c
	1058	ierr = NF_CLOSE(nid)
	1059	c
	1060	STOP
	1061	END

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format