Context Navigation

read_pstoke.F @ 1090

Last change on this file since 1090 was 940, checked in by Laurent Fairhead, 17 years ago
On remplace le fichier include dimphy.h par le module dimphy.F90i pour etre coherent avec le partout LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 14.2 KB

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

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

Download in other formats:

Original Format