Context Navigation

read_pstoke0.F @ 699

Last change on this file since 699 was 541, checked in by lmdzadmin, 20 years ago

Convergence avec la version d'Olivia Coindreau incluant:

le offline
les thermiques
mellor & yamada dans la couche limite

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 14.7 KB

Rev	Line
[524]	1	!
	2	! $Header$
	3	!
	4	c
	5	c
	6	subroutine read_pstoke0(irec,
	7	. zrec,zkon,zkev,airefi,phisfi,
	8	. t,mfu,mfd,en_u,de_u,en_d,de_d,coefh,
[541]	9	. fm_therm,en_therm,
[524]	10	. frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf)
	11
[541]	12	C******************************************************************************
	13	C Frederic HOURDIN, Abderrahmane IDELKADI
	14	C Lecture des parametres physique stockes online necessaires pour
	15	C recalculer offline le transport des traceurs sur la meme grille que online
	16	C A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)!
	17	C******************************************************************************
[524]	18
[541]	19
[524]	20	IMPLICIT NONE
	21
	22	#include "netcdf.inc"
	23	#include "dimensions.h"
	24	#include "paramet.h"
	25	#include "comconst.h"
	26	#include "comgeom.h"
	27	#include "temps.h"
	28	#include "ener.h"
	29	#include "logic.h"
	30	#include "description.h"
	31	#include "serre.h"
	32	#include "indicesol.h"
	33	#include "control.h"
	34	#include "dimphy.h"
	35
[541]	36	integer kon,kev,zkon,zkev
[524]	37	parameter(kon=iim*(jjm-1)+2,kev=llm)
[541]	38	REAL phisfi(kon)
	39	REAL phisfi2(iim,jjm+1),airefi2(iim,jjm+1)
[524]	40
[541]	41	REAL mfu(kon,kev), mfd(kon,kev)
	42	REAL en_u(kon,kev), de_u(kon,kev)
	43	REAL en_d(kon,kev), de_d(kon,kev)
	44	REAL coefh(kon,kev)
[524]	45
[541]	46	c abd 25 11 02
	47	c Thermiques
	48	REAL fm_therm(kon,kev),en_therm(kon,kev)
	49	REAL t(kon,kev)
[524]	50
[541]	51	REAL mfu2(iim,jjm+1,kev), mfd2(iim,jjm+1,kev)
	52	REAL en_u2(iim,jjm+1,kev), de_u2(iim,jjm+1,kev)
	53	REAL en_d2(iim,jjm+1,kev), de_d2(iim,jjm+1,kev)
	54	REAL coefh2(iim,jjm+1,kev)
	55	REAL t2(iim,jjm+1,kev)
	56	c Thermiques
	57	REAL fm_therm2(iim,jjm+1,kev)
	58	REAL en_therm2(iim,jjm+1,kev)
	59
	60	REAL pl(kev)
[524]	61	integer irec
[541]	62	integer xid,yid,zid,tid
	63	integer zrec,zim,zjm
	64	integer ncrec,nckon,nckev,ncim,ncjm
[524]	65
[541]	66	real airefi(kon)
	67	character*20 namedim
[524]	68
	69	c !! attention !!
	70	c attention il y a aussi le pb de def kon
	71	c dim de phis??
	72
[541]	73	REAL frac_impa(kon,kev), frac_nucl(kon,kev)
	74	REAL frac_impa2(iim,jjm+1,kev),
[524]	75	. frac_nucl2(iim,jjm+1,kev)
[541]	76	REAL pyu1(kon), pyv1(kon)
	77	REAL pyu12(iim,jjm+1), pyv12(iim,jjm+1)
	78	REAL ftsol(kon,nbsrf)
	79	REAL psrf(kon,nbsrf)
	80	REAL ftsol1(kon),ftsol2(kon),ftsol3(kon),ftsol4(kon)
	81	REAL psrf1(kon),psrf2(kon),psrf3(kon),psrf4(kon)
	82	REAL ftsol12(iim,jjm+1),ftsol22(iim,jjm+1),
[524]	83	. ftsol32(iim,jjm+1),
	84	. ftsol42(iim,jjm+1)
[541]	85	REAL psrf12(iim,jjm+1),psrf22(iim,jjm+1),psrf32(iim,jjm+1),
[524]	86	. psrf42(iim,jjm+1)
	87
	88	integer ncidp
	89	save ncidp
	90	integer varidmfu, varidmfd, varidps, varidenu, variddeu
	91	integer varidt
	92	integer varidend,varidded,varidch,varidfi,varidfn
[541]	93	c therm
	94	integer varidfmth,varidenth
[524]	95	integer varidyu1,varidyv1,varidpl,varidai,varididvt
	96	integer varidfts1,varidfts2,varidfts3,varidfts4
	97	integer varidpsr1,varidpsr2,varidpsr3,varidpsr4
	98	save varidmfu, varidmfd, varidps, varidenu, variddeu
	99	save varidt
	100	save varidend,varidded,varidch,varidfi,varidfn
[541]	101	c therm
	102	save varidfmth,varidenth
[524]	103	save varidyu1,varidyv1,varidpl,varidai,varididvt
	104	save varidfts1,varidfts2,varidfts3,varidfts4
	105	save varidpsr1,varidpsr2,varidpsr3,varidpsr4
	106
	107	integer l, i
	108	integer start(4),count(4),status
	109	real rcode
	110	logical first
	111	save first
	112	data first/.true./
	113
	114
	115
	116	c ---------------------------------------------
	117	c Initialisation de la lecture des fichiers
	118	c ---------------------------------------------
	119
	120	if (irec .eq. 0) then
	121
	122	ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode)
	123
	124	varidps=NCVID(ncidp,'phis',rcode)
	125	print*,'ncidp,varidps',ncidp,varidps
	126
	127	varidpl=NCVID(ncidp,'sig_s',rcode)
	128	print*,'ncidp,varidpl',ncidp,varidpl
	129
	130	varidai=NCVID(ncidp,'aire',rcode)
	131	print*,'ncidp,varidai',ncidp,varidai
	132
[541]	133	varidt=NCVID(ncidp,'t',rcode)
	134	print*,'ncidp,varidt',ncidp,varidt
	135
[524]	136	varidmfu=NCVID(ncidp,'mfu',rcode)
	137	print*,'ncidp,varidmfu',ncidp,varidmfu
	138
	139	varidmfd=NCVID(ncidp,'mfd',rcode)
	140	print*,'ncidp,varidmfd',ncidp,varidmfd
	141
	142	varidenu=NCVID(ncidp,'en_u',rcode)
	143	print*,'ncidp,varidenu',ncidp,varidenu
	144
	145	variddeu=NCVID(ncidp,'de_u',rcode)
	146	print*,'ncidp,variddeu',ncidp,variddeu
	147
	148	varidend=NCVID(ncidp,'en_d',rcode)
	149	print*,'ncidp,varidend',ncidp,varidend
	150
	151	varidded=NCVID(ncidp,'de_d',rcode)
	152	print*,'ncidp,varidded',ncidp,varidded
	153
	154	varidch=NCVID(ncidp,'coefh',rcode)
	155	print*,'ncidp,varidch',ncidp,varidch
[541]	156
	157	c Thermiques
	158	varidfmth=NCVID(ncidp,'fm_th',rcode)
	159	print*,'ncidp,varidfmth',ncidp,varidfmth
	160
	161	varidenth=NCVID(ncidp,'en_th',rcode)
	162	print*,'ncidp,varidenth',ncidp,varidenth
[524]	163
	164	varidfi=NCVID(ncidp,'frac_impa',rcode)
	165	print*,'ncidp,varidfi',ncidp,varidfi
	166
	167	varidfn=NCVID(ncidp,'frac_nucl',rcode)
	168	print*,'ncidp,varidfn',ncidp,varidfn
	169
	170	varidyu1=NCVID(ncidp,'pyu1',rcode)
	171	print*,'ncidp,varidyu1',ncidp,varidyu1
	172
	173	varidyv1=NCVID(ncidp,'pyv1',rcode)
	174	print*,'ncidp,varidyv1',ncidp,varidyv1
	175
	176	varidfts1=NCVID(ncidp,'ftsol1',rcode)
	177	print*,'ncidp,varidfts1',ncidp,varidfts1
	178
	179	varidfts2=NCVID(ncidp,'ftsol2',rcode)
	180	print*,'ncidp,varidfts2',ncidp,varidfts2
	181
	182	varidfts3=NCVID(ncidp,'ftsol3',rcode)
	183	print*,'ncidp,varidfts3',ncidp,varidfts3
	184
	185	varidfts4=NCVID(ncidp,'ftsol4',rcode)
	186	print*,'ncidp,varidfts4',ncidp,varidfts4
	187
	188	varidpsr1=NCVID(ncidp,'psrf1',rcode)
	189	print*,'ncidp,varidpsr1',ncidp,varidpsr1
	190
	191	varidpsr2=NCVID(ncidp,'psrf2',rcode)
	192	print*,'ncidp,varidpsr2',ncidp,varidpsr2
	193
	194	varidpsr3=NCVID(ncidp,'psrf3',rcode)
	195	print*,'ncidp,varidpsr3',ncidp,varidpsr3
	196
	197	varidpsr4=NCVID(ncidp,'psrf4',rcode)
	198	print*,'ncidp,varidpsr4',ncidp,varidpsr4
	199
	200	c ID pour les dimensions
	201
	202	status = nf_inq_dimid(ncidp,'y',yid)
	203	status = nf_inq_dimid(ncidp,'x',xid)
	204	status = nf_inq_dimid(ncidp,'sig_s',zid)
	205	status = nf_inq_dimid(ncidp,'time_counter',tid)
	206
	207	c lecture des dimensions
	208
	209	status = nf_inq_dim(ncidp,yid,namedim,ncjm)
	210	status = nf_inq_dim(ncidp,xid,namedim,ncim)
	211	status = nf_inq_dim(ncidp,zid,namedim,nckev)
	212	status = nf_inq_dim(ncidp,tid,namedim,ncrec)
	213
	214	zrec=ncrec
	215	zkev=nckev
	216	zim=ncim
	217	zjm=ncjm
	218
	219	zkon=zim*(zjm-2)+2
	220
	221	write(,) 'read_pstoke : zrec = ', zrec
	222	write(,) 'read_pstoke : kev = ', zkev
	223	write(,) 'read_pstoke : zim = ', zim
	224	write(,) 'read_pstoke : zjm = ', zjm
	225	write(,) 'read_pstoke : kon = ', zkon
	226
	227	c niveaux de pression
	228
	229	status=NF_GET_VARA_REAL(ncidp,varidpl,1,kev,pl)
	230
	231	c lecture de aire et phis
	232
	233	start(1)=1
	234	start(2)=1
	235	start(3)=1
	236	start(4)=0
	237
	238	count(1)=zim
	239	count(2)=zjm
	240	count(3)=1
	241	count(4)=0
	242
	243	c
[541]	244	C** Geopotentiel au sol *************************************
[524]	245	c phis
[541]	246	#ifdef NC_DOUBLE
	247	status=NF_GET_VARA_DOUBLE(ncidp,varidps,start,count,phisfi2)
	248	#else
	249	status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2)
	250	#endif
[524]	251	call gr_ecrit_fi(1,kon,iim,jjm+1,phisfi2,phisfi)
	252
[541]	253	C** Aires des mails aux sol **********************************
[524]	254	c aire
[541]	255	#ifdef NC_DOUBLE
	256	status=NF_GET_VARA_DOUBLE(ncidp,varidai,start,count,airefi2)
	257	#else
	258	status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2)
	259	#endif
[524]	260	call gr_ecrit_fi(1,kon,iim,jjm+1,airefi2,airefi)
	261	else
	262
	263	print*,'ok1'
	264
	265	c ---------------------
	266	c lecture des champs
	267	c ---------------------
	268
	269	print*,'WARNING!!! Il n y a pas de test de coherence'
	270	print*,'sur le nombre de niveaux verticaux dans le fichier nc'
	271
	272	start(1)=1
	273	start(2)=1
	274	start(3)=1
	275	start(4)=irec
	276
	277	count(1)=zim
	278	count(2)=zjm
	279	count(3)=kev
	280	count(4)=1
	281
[541]	282	C** Temperature ******************************************
	283	cA FAIRE : Es-ce necessaire ?
[524]	284
	285	c abder t
[541]	286	#ifdef NC_DOUBLE
	287	status=NF_GET_VARA_DOUBLE(ncidp,varidt,start,count,t2)
	288	#else
	289	status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2)
	290	#endif
[524]	291	call gr_ecrit_fi(kev,kon,iim,jjm+1,t2,t)
	292
[541]	293	C** Flux pour la convection (Tiedtk) ******************************************
[524]	294	c mfu
[541]	295	#ifdef NC_DOUBLE
	296	status=NF_GET_VARA_DOUBLE(ncidp,varidmfu,start,count,mfu2)
	297	#else
	298	status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2)
	299	#endif
[524]	300	call gr_ecrit_fi(kev,kon,iim,jjm+1,mfu2,mfu)
	301
	302	c mfd
[541]	303	#ifdef NC_DOUBLE
	304	status=NF_GET_VARA_DOUBLE(ncidp,varidmfd,start,count,mfd2)
	305	#else
	306	status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2)
	307	#endif
[524]	308	call gr_ecrit_fi(kev,kon,iim,jjm+1,mfd2,mfd)
	309
	310	c en_u
[541]	311	#ifdef NC_DOUBLE
	312	status=NF_GET_VARA_DOUBLE(ncidp,varidenu,start,count,en_u2)
	313	#else
	314	status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2)
	315	#endif
[524]	316	call gr_ecrit_fi(kev,kon,iim,jjm+1,en_u2,en_u)
	317
	318	c de_u
[541]	319	#ifdef NC_DOUBLE
	320	status=NF_GET_VARA_DOUBLE(ncidp,variddeu,start,count,de_u2)
	321	#else
	322	status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2)
	323	#endif
[524]	324	call gr_ecrit_fi(kev,kon,iim,jjm+1,de_u2,de_u)
	325
	326	c en_d
[541]	327	#ifdef NC_DOUBLE
	328	status=NF_GET_VARA_DOUBLE(ncidp,varidend,start,count,en_d2)
	329	#else
	330	status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2)
	331	#endif
[524]	332	call gr_ecrit_fi(kev,kon,iim,jjm+1,en_d2,en_d)
	333
	334	c de_d
[541]	335	#ifdef NC_DOUBLE
	336	status=NF_GET_VARA_DOUBLE(ncidp,varidded,start,count,de_d2)
	337	#else
	338	status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2)
	339	#endif
[524]	340	call gr_ecrit_fi(kev,kon,iim,jjm+1,de_d2,de_d)
	341
[541]	342	C** Coefficient de mellange turbulent *****************************************
[524]	343	c coefh
	344	print*,'LECTURE de coefh a irec =',irec
[541]	345	#ifdef NC_DOUBLE
	346	status=NF_GET_VARA_DOUBLE(ncidp,varidch,start,count,coefh2)
	347	#else
	348	status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2)
	349	#endif
[524]	350	call gr_ecrit_fi(kev,kon,iim,jjm+1,coefh2,coefh)
[541]	351	c call dump2d(iip1,jjp1,coefh2(1,2),'COEFH2READ ')
	352	c call dump2d(iim ,jjm ,coefh (2,2),'COEFH2READ ')
[524]	353
[541]	354	C** Flux ascendants et entrant dans le thermique ********************************
	355	cThermiques
	356	print*,'LECTURE de fm_therm a irec =',irec
	357	#ifdef NC_DOUBLE
	358	status=NF_GET_VARA_DOUBLE(ncidp,varidfmth,start,
	359	. count,fm_therm2)
	360	#else
	361	status=NF_GET_VARA_REAL(ncidp,varidfmth,start,
	362	. count,fm_therm2)
	363	#endif
	364	call gr_ecrit_fi(kev,kon,iim,jjm+1,fm_therm2,fm_therm)
	365	print*,'LECTURE de en_therm a irec =',irec
	366	#ifdef NC_DOUBLE
	367	status=NF_GET_VARA_DOUBLE(ncidp,varidenth,start,
	368	. count,en_therm2)
	369	#else
	370	status=NF_GET_VARA_REAL(ncidp,varidenth,start,
	371	. count,en_therm2)
	372	#endif
	373	call gr_ecrit_fi(kev,kon,iim,jjm+1,en_therm2,en_therm)
	374
	375	C** Coefficients de lessivage *****************************************
	376	c frac_impa
	377	#ifdef NC_DOUBLE
	378	status=NF_GET_VARA_DOUBLE(ncidp,varidfi,start,count,frac_impa2)
	379	#else
	380	status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2)
	381	#endif
	382	call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_impa2,frac_impa)
	383
	384	c frac_nucl
	385
	386	#ifdef NC_DOUBLE
	387	status=NF_GET_VARA_DOUBLE(ncidp,varidfn,start,count,frac_nucl2)
	388	#else
	389	status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2)
	390	#endif
	391	call gr_ecrit_fi(kev,kon,iim,jjm+1,frac_nucl2,frac_nucl)
	392
	393	C** Vents aux sol ******************************************
	394
[524]	395	start(3)=irec
	396	start(4)=0
	397	count(3)=1
	398	count(4)=0
	399
	400	c pyu1
	401	print*,'LECTURE de yu1 a irec =',irec
[541]	402	#ifdef NC_DOUBLE
	403	status=NF_GET_VARA_DOUBLE(ncidp,varidyu1,start,count,pyu12)
	404	#else
	405	status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12)
	406	#endif
[524]	407	call gr_ecrit_fi(1,kon,iim,jjm+1,pyu12,pyu1)
	408
	409	c pyv1
	410	print*,'LECTURE de yv1 a irec =',irec
[541]	411	#ifdef NC_DOUBLE
	412	status=NF_GET_VARA_DOUBLE(ncidp,varidyv1,start,count,pyv12)
	413	#else
	414	status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12)
	415	#endif
[524]	416	call gr_ecrit_fi(1,kon,iim,jjm+1,pyv12,pyv1)
	417
[541]	418	C** Temerature au sol ******************************************
[524]	419	c ftsol1
	420	print*,'LECTURE de ftsol1 a irec =',irec
[541]	421	#ifdef NC_DOUBLE
	422	status=NF_GET_VARA_DOUBLE(ncidp,varidfts1,start,count,ftsol12)
	423	#else
[524]	424	status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12)
[541]	425	#endif
[524]	426	call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol12,ftsol1)
	427
	428	c ftsol2
	429	print*,'LECTURE de ftsol2 a irec =',irec
[541]	430	#ifdef NC_DOUBLE
	431	status=NF_GET_VARA_DOUBLE(ncidp,varidfts2,start,count,ftsol22)
	432	#else
[524]	433	status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22)
[541]	434	#endif
[524]	435	call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol22,ftsol2)
	436
	437	c ftsol3
	438	print*,'LECTURE de ftsol3 a irec =',irec
[541]	439	#ifdef NC_DOUBLE
	440	status=NF_GET_VARA_DOUBLE(ncidp,varidfts3,start,count,ftsol32)
	441	#else
[524]	442	status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32)
[541]	443	#endif
[524]	444	call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol32,ftsol3)
	445
	446	c ftsol4
[541]	447	#ifdef NC_DOUBLE
	448	status=NF_GET_VARA_DOUBLE(ncidp,varidfts4,start,count,ftsol42)
	449	#else
[524]	450	status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42)
[541]	451	#endif
[524]	452	call gr_ecrit_fi(1,kon,iim,jjm+1,ftsol42,ftsol4)
	453
[541]	454	C** Nature sol ******************************************
[524]	455	c psrf1
[541]	456	#ifdef NC_DOUBLE
	457	status=NF_GET_VARA_DOUBLE(ncidp,varidpsr1,start,count,psrf12)
	458	#else
[524]	459	status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12)
[541]	460	#endif
[524]	461	c call dump2d(iip1-1,jjm+1,psrf12,'PSRF1NC')
	462	call gr_ecrit_fi(1,kon,iim,jjm+1,psrf12,psrf1)
	463
	464	c psrf2
[541]	465	#ifdef NC_DOUBLE
	466	status=NF_GET_VARA_DOUBLE(ncidp,varidpsr2,start,count,psrf22)
	467	#else
[524]	468	status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22)
[541]	469	#endif
[524]	470	c call dump2d(iip1-1,jjm+1,psrf22,'PSRF2NC')
	471	call gr_ecrit_fi(1,kon,iim,jjm+1,psrf22,psrf2)
	472
	473	c psrf3
[541]	474	#ifdef NC_DOUBLE
	475	status=NF_GET_VARA_DOUBLE(ncidp,varidpsr3,start,count,psrf32)
	476	#else
[524]	477	status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32)
[541]	478	#endif
[524]	479	call gr_ecrit_fi(1,kon,iim,jjm+1,psrf32,psrf3)
	480
	481	c psrf4
[541]	482	#ifdef NC_DOUBLE
	483	status=NF_GET_VARA_DOUBLE(ncidp,varidpsr4,start,count,psrf42)
	484	#else
[524]	485	status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42)
[541]	486	#endif
[524]	487	call gr_ecrit_fi(1,kon,iim,jjm+1,psrf42,psrf4)
	488
	489	do i = 1,kon
	490
	491	psrf(i,1) = psrf1(i)
	492	psrf(i,2) = psrf2(i)
	493	psrf(i,3) = psrf3(i)
[541]	494	c test abderr
	495	c print*,'Dans read_pstoke psrf3 =',psrf3(i),i
[524]	496	psrf(i,4) = psrf4(i)
	497
	498	ftsol(i,1) = ftsol1(i)
	499	ftsol(i,2) = ftsol2(i)
	500	ftsol(i,3) = ftsol3(i)
	501	ftsol(i,4) = ftsol4(i)
	502
	503	enddo
	504
	505	endif
	506
	507	return
	508
	509	end
	510

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

Download in other formats:

Original Format