c c $Header c subroutine read_pstoke(irec, . zrec,zklono,zklevo,airefi,phisfi, . t,mfu,mfd,en_u,de_u,en_d,de_d,coefh, . frac_impa,frac_nucl,pyu1,pyv1,ftsol,psrf) IMPLICIT NONE #include "netcdf.inc" #include "dimensions.h" #include "paramet.h" #include "comconst.h" #include "comgeom.h" #include "temps.h" #include "ener.h" #include "logic.h" #include "description.h" #include "serre.h" #include "indicesol.h" #include "control.h" #include "dimphy.h" integer*4 klono,klevo,imo,jmo parameter (imo=iim/2,jmo=(jjm+1)/2) parameter(klono=(jmo-1)*imo+2,klevo=llm) REAL*4 phisfi(klono) REAL*4 phisfi2(imo,jmo+1),airefi2(imo,jmo+1) REAL*4 mfu(klono,klevo), mfd(klono,klevo) REAL*4 en_u(klono,klevo), de_u(klono,klevo) REAL*4 en_d(klono,klevo), de_d(klono,klevo) REAL*4 coefh(klono,klevo) REAL*4 mfu2(imo,jmo+1,klevo), mfd2(imo,jmo+1,klevo) REAL*4 en_u2(imo,jmo+1,klevo), de_u2(imo,jmo+1,klevo) REAL*4 en_d2(imo,jmo+1,klevo), de_d2(imo,jmo+1,klevo) REAL*4 coefh2(imo,jmo+1,klevo) REAL*4 pl(klevo) integer irec integer*4 xid,yid,zid,tid real zrec,zklono,zklevo,zim,zjm integer*4 ncrec,ncklono,ncklevo,ncim,ncjm real*4 airefi(klono) character namedim c !! attention !! c attention il y a aussi le pb de def klono c dim de phis?? REAL*4 frac_impa(klono,klevo), frac_nucl(klono,klevo) REAL*4 frac_impa2(imo,jmo+1,klevo), . frac_nucl2(imo,jmo+1,klevo) REAL*4 pyu1(klono), pyv1(klono) REAL*4 pyu12(imo,jmo+1), pyv12(imo,jmo+1) REAL*4 ftsol(klono,nbsrf) REAL*4 psrf(klono,nbsrf) REAL*4 ftsol1(klono),ftsol2(klono),ftsol3(klono),ftsol4(klono) REAL*4 psrf1(klono),psrf2(klono),psrf3(klono),psrf4(klono) REAL*4 ftsol12(imo,jmo+1),ftsol22(imo,jmo+1), . ftsol32(imo,jmo+1), . ftsol42(imo,jmo+1) REAL*4 psrf12(imo,jmo+1),psrf22(imo,jmo+1),psrf32(imo,jmo+1), . psrf42(imo,jmo+1) REAL*4 t(klono,klevo) REAL*4 t2(imo,jmo+1) integer ncidp save ncidp integer varidt integer varidmfu, varidmfd, varidps, varidenu, variddeu integer varidend,varidded,varidch,varidfi,varidfn integer varidyu1,varidyv1,varidpl,varidai,varididvt integer varidfts1,varidfts2,varidfts3,varidfts4 integer varidpsr1,varidpsr2,varidpsr3,varidpsr4 save varidmfu, varidmfd, varidps, varidenu, variddeu save varidend,varidded,varidch,varidfi,varidfn save varidyu1,varidyv1,varidpl,varidai,varididvt save varidfts1,varidfts2,varidfts3,varidfts4 save varidpsr1,varidpsr2,varidpsr3,varidpsr4 save varidt integer l, i integer start(4),count(4),status real rcode logical first save first data first/.true./ c --------------------------------------------- c Initialisation de la lecture des fichiers c --------------------------------------------- if (irec .eq. 0) then ncidp=NCOPN('phystoke.nc',NCNOWRIT,rcode) varidps=NCVID(ncidp,'phis',rcode) print*,'ncidp,varidps',ncidp,varidps varidpl=NCVID(ncidp,'sig_s',rcode) print*,'ncidp,varidpl',ncidp,varidpl varidai=NCVID(ncidp,'aire',rcode) print*,'ncidp,varidai',ncidp,varidai varidt=NCVID(ncidp,'t',rcode) print*,'ncidp,varidt',ncidp,varidt varidmfu=NCVID(ncidp,'mfu',rcode) print*,'ncidp,varidmfu',ncidp,varidmfu varidmfd=NCVID(ncidp,'mfd',rcode) print*,'ncidp,varidmfd',ncidp,varidmfd varidenu=NCVID(ncidp,'en_u',rcode) print*,'ncidp,varidenu',ncidp,varidenu variddeu=NCVID(ncidp,'de_u',rcode) print*,'ncidp,variddeu',ncidp,variddeu varidend=NCVID(ncidp,'en_d',rcode) print*,'ncidp,varidend',ncidp,varidend varidded=NCVID(ncidp,'de_d',rcode) print*,'ncidp,varidded',ncidp,varidded varidch=NCVID(ncidp,'coefh',rcode) print*,'ncidp,varidch',ncidp,varidch varidfi=NCVID(ncidp,'frac_impa',rcode) print*,'ncidp,varidfi',ncidp,varidfi varidfn=NCVID(ncidp,'frac_nucl',rcode) print*,'ncidp,varidfn',ncidp,varidfn varidyu1=NCVID(ncidp,'pyu1',rcode) print*,'ncidp,varidyu1',ncidp,varidyu1 varidyv1=NCVID(ncidp,'pyv1',rcode) print*,'ncidp,varidyv1',ncidp,varidyv1 varidfts1=NCVID(ncidp,'ftsol1',rcode) print*,'ncidp,varidfts1',ncidp,varidfts1 varidfts2=NCVID(ncidp,'ftsol2',rcode) print*,'ncidp,varidfts2',ncidp,varidfts2 varidfts3=NCVID(ncidp,'ftsol3',rcode) print*,'ncidp,varidfts3',ncidp,varidfts3 varidfts4=NCVID(ncidp,'ftsol4',rcode) print*,'ncidp,varidfts4',ncidp,varidfts4 varidpsr1=NCVID(ncidp,'psrf1',rcode) print*,'ncidp,varidpsr1',ncidp,varidpsr1 varidpsr2=NCVID(ncidp,'psrf2',rcode) print*,'ncidp,varidpsr2',ncidp,varidpsr2 varidpsr3=NCVID(ncidp,'psrf3',rcode) print*,'ncidp,varidpsr3',ncidp,varidpsr3 varidpsr4=NCVID(ncidp,'psrf4',rcode) print*,'ncidp,varidpsr4',ncidp,varidpsr4 c ID pour les dimensions status = nf_inq_dimid(ncidp,'y',yid) status = nf_inq_dimid(ncidp,'x',xid) status = nf_inq_dimid(ncidp,'sig_s',zid) status = nf_inq_dimid(ncidp,'time_counter',tid) c lecture des dimensions status = nf_inq_dim(ncidp,yid,namedim,ncjm) status = nf_inq_dim(ncidp,xid,namedim,ncim) status = nf_inq_dim(ncidp,zid,namedim,ncklevo) status = nf_inq_dim(ncidp,tid,namedim,ncrec) zrec=ncrec zklevo=ncklevo zim=ncim zjm=ncjm zklono=zim*(zjm-2)+2 write(*,*) 'read_pstoke : zrec = ', zrec write(*,*) 'read_pstoke : zklevo = ', zklevo write(*,*) 'read_pstoke : zim = ', zim write(*,*) 'read_pstoke : zjm = ', zjm write(*,*) 'read_pstoke : zklono = ', zklono c niveaux de pression status=NF_GET_VARA_REAL(ncidp,varidpl,1,zklevo,pl) c lecture de aire et phis start(1)=1 start(2)=1 start(3)=1 start(4)=0 count(1)=zim count(2)=zjm count(3)=1 count(4)=0 c phis status=NF_GET_VARA_REAL(ncidp,varidps,start,count,phisfi2) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*1,phisfi2) c call dump2d(iip1-1,jjp1,phisfi2,'PHISNC') call gr_ecrit_fi(1,klono,imo,jmo+1,phisfi2,phisfi) c aire status=NF_GET_VARA_REAL(ncidp,varidai,start,count,airefi2) c call correctbid(iim,jjp1*1,airefi2) c call dump2d(iip1-1,jjp1,airefi2,'AIRENC') call gr_ecrit_fi(1,klono,imo,jmo+1,airefi2,airefi) else print*,'ok1' c --------------------- c lecture des champs c --------------------- print*,'WARNING!!! Il n y a pas de test de coherence' print*,'sur le nombre de niveaux verticaux dans le fichier nc' start(1)=1 start(2)=1 start(3)=1 start(4)=irec count(1)=zim count(2)=zjm count(3)=zklevo count(4)=1 c frac_impa status=NF_GET_VARA_REAL(ncidp,varidfi,start,count,frac_impa2) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*klevo,frac_impa2) c call dump2d(iip1-1,jjp1,frac_impa2,'FINC COUCHE 1') call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_impa2,frac_impa) c frac_nucl status=NF_GET_VARA_REAL(ncidp,varidfn,start,count,frac_nucl2) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*klevo,frac_nucl2) c call dump2d(iip1-1,jjp1,frac_nucl2,'FINC COUCHE 1') call gr_ecrit_fi(klevo,klono,imo,jmo+1,frac_nucl2,frac_nucl) c abder t status=NF_GET_VARA_REAL(ncidp,varidt,start,count,t2) call gr_ecrit_fi(klevo,klono,imo,jmo+1,t2,t) c mfu status=NF_GET_VARA_REAL(ncidp,varidmfu,start,count,mfu2) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*klevo,mfu2) c call dump2d(iip1-1,jjp1,mfu2,'MFUNC COUCHE 1') call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfu2,mfu) c mfd status=NF_GET_VARA_REAL(ncidp,varidmfd,start,count,mfd2) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*klevo,mfd2) c call dump2d(iip1-1,jjp1,mfd2,'MFDNC COUCHE 1') call gr_ecrit_fi(klevo,klono,imo,jmo+1,mfd2,mfd) c en_u status=NF_GET_VARA_REAL(ncidp,varidenu,start,count,en_u2) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*klevo,en_u2) c call dump2d(iip1-1,jjp1,en_u2,'ENUNC COUCHE 1') call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_u2,en_u) c de_u status=NF_GET_VARA_REAL(ncidp,variddeu,start,count,de_u2) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*klevo,de_u2) c call dump2d(iip1-1,jjp1,de_u2,'DEUNC COUCHE 1') call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_u2,de_u) c en_d status=NF_GET_VARA_REAL(ncidp,varidend,start,count,en_d2) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*klevo,en_d2) c call dump2d(iip1-1,jjp1,en_d2,'ENDNC COUCHE 1') call gr_ecrit_fi(klevo,klono,imo,jmo+1,en_d2,en_d) c de_d status=NF_GET_VARA_REAL(ncidp,varidded,start,count,de_d2) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*klevo,de_d2) c call dump2d(iip1-1,jjp1,de_d2,'DEDNC COUCHE 1') call gr_ecrit_fi(klevo,klono,imo,jmo+1,de_d2,de_d) c coefh status=NF_GET_VARA_REAL(ncidp,varidch,start,count,coefh2) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*klevo,coefh2) c call dump2d(iip1-1,jjp1,coefh2,'CHNC COUCHE 1') call gr_ecrit_fi(klevo,klono,imo,jmo+1,coefh2,coefh) start(3)=irec start(4)=0 count(3)=1 count(4)=0 c pyu1 status=NF_GET_VARA_REAL(ncidp,varidyu1,start,count,pyu12) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*1,pyu12) c call dump2d(iip1-1,jjp1,pyu12,'PYU1NC') call gr_ecrit_fi(1,klono,imo,jmo+1,pyu12,pyu1) c pyv1 status=NF_GET_VARA_REAL(ncidp,varidyv1,start,count,pyv12) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*1,pyv12) c call dump2d(iip1-1,jjp1,pyv12,'PYV1NC') call gr_ecrit_fi(1,klono,imo,jmo+1,pyv12,pyv1) c ftsol1 status=NF_GET_VARA_REAL(ncidp,varidfts1,start,count,ftsol12) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*1,ftsol12) c call dump2d(iip1-1,jjp1,ftsol12,'FTS1NC') call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol12,ftsol1) c ftsol2 status=NF_GET_VARA_REAL(ncidp,varidfts2,start,count,ftsol22) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*1,ftsol22) c call dump2d(iip1-1,jjp1,ftsol22,'FTS2NC') call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol22,ftsol2) c ftsol3 status=NF_GET_VARA_REAL(ncidp,varidfts3,start,count,ftsol32) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*1,ftsol32) c call dump2d(iip1-1,jjp1,ftsol32,'FTS3NC') call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol32,ftsol3) c ftsol4 status=NF_GET_VARA_REAL(ncidp,varidfts4,start,count,ftsol42) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*1,ftsol42) c call dump2d(iip1-1,jjp1,ftsol42,'FTS4NC') call gr_ecrit_fi(1,klono,imo,jmo+1,ftsol42,ftsol4) c psrf1 status=NF_GET_VARA_REAL(ncidp,varidpsr1,start,count,psrf12) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*1,psrf12) c call dump2d(iip1-1,jjp1,psrf12,'PSRF1NC') call gr_ecrit_fi(1,klono,imo,jmo+1,psrf12,psrf1) c psrf2 status=NF_GET_VARA_REAL(ncidp,varidpsr2,start,count,psrf22) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*1,psrf22) c call dump2d(iip1-1,jjp1,psrf22,'PSRF2NC') call gr_ecrit_fi(1,klono,imo,jmo+1,psrf22,psrf2) c psrf3 status=NF_GET_VARA_REAL(ncidp,varidpsr3,start,count,psrf32) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*1,psrf32) c call dump2d(iip1-1,jjp1,psrf32,'PSRF3NC') call gr_ecrit_fi(1,klono,imo,jmo+1,psrf32,psrf3) c psrf4 status=NF_GET_VARA_REAL(ncidp,varidpsr4,start,count,psrf42) c print*,'WARNING!!! Correction bidon pour palier a un ' c print*,'probleme dans la creation des fichiers nc' c call correctbid(iim,jjp1*1,psrf42) c call dump2d(iip1-1,jjp1,psrf42,'PSRF4NC') call gr_ecrit_fi(1,klono,imo,jmo+1,psrf42,psrf4) do i = 1,klono psrf(i,1) = psrf1(i) psrf(i,2) = psrf2(i) psrf(i,3) = psrf3(i) psrf(i,4) = psrf4(i) ftsol(i,1) = ftsol1(i) ftsol(i,2) = ftsol2(i) ftsol(i,3) = ftsol3(i) ftsol(i,4) = ftsol4(i) enddo endif return end