Context Navigation

read_pstoke0.F @ 1136

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

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

Download in other formats:

Original Format