Context Navigation

read_pstoke0.F @ 4855

Last change on this file since 4855 was 256, checked in by lmdz, 23 years ago
Recuperation de la version qui se trouvait dans dyn3d et remise des NC_DOUBLE pour VPP. MAF LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 12.4 KB

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

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

Download in other formats:

Original Format