*=*=*=*= xvik.html =*=*=*=*
PROGRAM xvik IMPLICIT NONE c======================================================================= c c Frederic Hourdin Decembre 1990 c c programme de calcul de moyennes zonales adapter pour le format c LMD de Jan Polcher et Laurent Li. c c le progreamme demande un nombre de sorties nsor c Si nsor<0 le programme genere le fichier coord.def contenant c les coordonnees latitudes et niveaux sigma c Si nsor>0 le programme sort les variables u,v,t plus les c pressions au sol. c c======================================================================= c----------------------------------------------------------------------- c declarations: c ------------- #include "dimensions.h" #include "paramet.h" #include "comconst.h" #include "comdissip.h" #include "comvert.h" #include "comgeom2.h" #include "logic.h" #include "temps.h" #include "control.h" #include "ener.h" #include "drsdef.h" #include "description.h" INTEGER itau,nbpas,nbpasmx PARAMETER(nbpasmx=1000000) REAL temps(nbpasmx) INTEGER unitlec INTEGER i,j,l,jj c Declarations DRS: c ----------------- INTEGER r4, ierr, dimtype PARAMETER (r4 = IDRS_BYTES_PER_WORD) INTEGER setname, aslun, cluvdb, cllun,inqdict INTEGER drsread, getcdim CHARACTER*120 dimsou, dimnam*16, dimtit*80 CHARACTER*40 dimunit CHARACTER*100 varname c declarations pour les points viking: c ------------------------------------ INTEGER ivik(2),jvik(2),ifile(2),iv REAL lonvik(2),latvik(2),phivik(2),phisim(2) REAL unanj c variables meteo: c ---------------- REAL vnat(iip1,jjm,llm),unat(iip1,jjp1,llm) REAL t(iip1,jjp1,llm),ps(iip1,jjp1),pstot, phis(iip1,jjp1) REAL zp1,zp2,zu,zv,zw(0:1,0:1,2),zalpha,zbeta LOGICAL firstcal,lcal,latcal,lvent,day_ls INTEGER*4 day0 REAL ziceco2(iip1,jjp1) REAL day,zt,sollong,sol,dayw REAL airtot1,gh INTEGER ii,iyear,kyear CHARACTER*2 chr2 LOGICAL ldrs c declarations de l'interface avec mywrite: c ----------------------------------------- CHARACTER file*80 CHARACTER pathchmp*80,pathsor*80,nomfich*20 c externe: c -------- EXTERNAL iniconst,inigeom,covcont,mywrite EXTERNAL inifilr,exner,pbar EXTERNAL solarlong,coordij,moy2 EXTERNAL SSUM REAL SSUM EXTERNAL lnblnk INTEGER lnblnk c----------------------------------------------------------------------- c initialisations: c ---------------- unanj=667.9 print*,'WARNING!!!',unanj,'Jours/an' ldrs=.true. lcal=.true. latcal=.true. lvent=.false. day_ls=.true. c lecture du fichier anl.def phivik(1)=-1000. phivik(2)=-2000. OPEN(99,file='xvik.def',form='formatted') READ(99,*) READ(99,*,iostat=ierr) phivik IF(ierr.NE.0) GOTO 105 READ(99,*,END=105) READ(99,'(a)',END=105) pathchmp READ(99,*,END=105) READ(99,'(a)',END=105) pathsor READ(99,*,END=105) READ(99,'(l1)',END=105) day_ls READ(99,'(l1)',END=105) READ(99,'(l1)',END=105) lcal READ(99,'(l1)',END=105) READ(99,'(l1)',END=105) lvent READ(99,'(l1)',END=105) READ(99,'(l1)',END=105) latcal 105 CONTINUE CLOSE(99) write (*,*)'>>>>>>>>>>>>>>>>', phivik,g DO iv=1,2 phivik(iv)=phivik(iv)*3.73 END DO c----------------------------------------------------------------------- c----------------------------------------------------------------------- c ouverture des fichiers xgraph: c ------------------------------ ifile(1)=12 ifile(2)=13 kyear=-1 OPEN(77,file='xlongday',form='formatted') unitlec=11 c PRINT*,'entrer le nom du fichier DRS' READ(5,'(a)') nomfich c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c grande boucle sur les fichiers histoire: c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% firstcal=.true. DO WHILE(lnblnk(nomfich).GT.0.AND.lnblnk(nomfich).LT.20) PRINT *,'nomfich : ',nomfich c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% file=pathchmp(1:lnblnk(pathchmp))//'/'// s nomfich(1:lnblnk(nomfich)) PRINT*,'file',file PRINT*,'timestep',dtvr IF(ldrs) THEN ierr = aslun(unitlec,file(1:lnblnk(file))//'.dic', . unitlec+1,file(1:lnblnk(file))//'.dat',IDRS_READ) ELSE PRINT*,'Ouverture binaire ',file OPEN(unitlec,file=file,status='old',form='unformatted', . iostat=ierr) ENDIF c---------------------------------------------------------------------- c initialisation de la physique: c ------------------------------ CALL readhead(unitlec,ldrs,day0,phis) WRITE (*,*) 'day0 = ' , day0 CALL iniconst CALL inigeom CALL inifilr c sigma aux niveaux s: DO l=1,llm print*,'sig_s(',l,') = ',sig_s(l) ENDDO ierr = CLUVDB() ierr = SETNAME(' ','u',' ',' ',' ') ierr = INQDICT(unitlec, IDRS_GETFIRSTVAR) ierr = GETCDIM(4,dimsou,dimnam,dimtit, & dimunit,dimtype, nbpasmx,temps,nbpas) PRINT*,'dimsou',dimsou PRINT*,'dimnam',dimnam PRINT*,'dimtit',dimtit PRINT*,'dimunit',dimunit PRINT*,'dimtype',dimtype PRINT*,'nbpas',nbpas PRINT*,'nbpasmx',nbpasmx PRINT*,'!!!WARNING il faut generaliser la lecture du temps' PRINT*,'temps',(temps(itau),itau=1,10) c----------------------------------------------------------------------- c coordonnees des point Viking: c ----------------------------- latvik(1)=22.3*pi/180. c lonvik(1)=-47.9*pi/180. c !!! WARNING on triche! lonvik(1)=-45.2*pi/180. latvik(2)=47.7*pi/180. lonvik(2)=(360.-225.7)*pi/180. c ponderations pour les 4 points autour de Viking DO iv=1,2 CALL coordij(lonvik(iv),latvik(iv),ivik(iv),jvik(iv)) IF(lonvik(iv).lt.rlonv(ivik(iv))) THEN ivik(iv)=ivik(iv)-1 ENDIF IF(latvik(iv).gt.rlatu(jvik(iv))) THEN jvik(iv)=jvik(iv)-1 ENDIF zalpha=(lonvik(iv)-rlonv(ivik(iv)))/ s (rlonv(ivik(iv)+1)-rlonv(ivik(iv))) zbeta=(latvik(iv)-rlatu(jvik(iv)))/ s (rlatu(jvik(iv)+1)-rlatu(jvik(iv))) zw(0,0,iv)=(1.-zalpha)*(1.-zbeta) zw(1,0,iv)=zalpha*(1.-zbeta) zw(0,1,iv)=(1.-zalpha)*zbeta zw(1,1,iv)=zalpha*zbeta ENDDO c altitude reelle et modele aux points Viking DO iv=1,2 phisim(iv)=0. DO jj=0,1 j=jvik(iv)+jj DO ii=0,1 i=ivik(iv)+ii phisim(iv)=phisim(iv)+zw(ii,jj,iv)*phis(i,j) ENDDO ENDDO ENDDO PRINT*,'relief aux points Viking pour les sorties:',phivik c---------------------------------------------------------------------- c lectures des etats: c ------------------- airtot1=1./(SSUM(ip1jmp1,aire,1)-SSUM(jjp1,aire,iip1)) c====================================================================== c debut de la boucle sur les etats dans un fichier histoire: c====================================================================== DO itau=1,nbpas c lecture drs des champs: c ----------------------- varname='u' ierr=drsread (unitlec,varname,unat,itau) c PRINT*,'unat',unat(iip1/2,jjp1/2,llm/2) varname='v' ierr=drsread (unitlec,varname,vnat,itau) c PRINT*,'vnat',vnat(iip1/2,jjp1/2,llm/2) varname='T' ierr=drsread (unitlec,varname,t,itau) PRINT*,'t',t(iip1/2,jjp1/2,llm/2) varname='ps' ierr=drsread (unitlec,varname,ps,itau) PRINT*,'ps',ps(iip1/2,jjp1/2) c Gestion du temps c ---------------- day=temps(itau) PRINT*,'day ',day CALL solarlong(day,sollong) sol=day+day0+461. iyear=sol/unanj sol=sol-iyear*unanj c c Ouverture / fermeture des fichiers c ---------------------------------- IF (iyear.NE.kyear) THEN WRITE(chr2(1:1),'(i1)') iyear+1 IF(iyear.GE.9) WRITE(chr2,'(i2)') iyear+1 kyear=iyear DO ii=1,2 CLOSE(10+ifile(ii)) CLOSE(2+ifile(ii)) CLOSE(4+ifile(ii)) CLOSE(6+ifile(ii)) CLOSE(8+ifile(ii)) CLOSE(16+ifile(ii)) CLOSE(12+ifile(ii)) CLOSE(14+ifile(ii)) CLOSE(97) CLOSE(98) ENDDO CLOSE(5+ifile(1)) OPEN(ifile(1)+10,file='xpsol1'//chr2,form='formatted') OPEN(ifile(2)+10,file='xpsol2'//chr2,form='formatted') OPEN(ifile(1)+8,file='xbpsol1'//chr2,form='formatted') OPEN(ifile(2)+8,file='xbpsol2'//chr2,form='formatted') c OPEN(ifile(1)+2,file='xlps1'//chr2,form='formatted') c OPEN(ifile(2)+2,file='xlps2'//chr2,form='formatted') IF(lcal) THEN c OPEN(ifile(2)+4,file='xpressud'//chr2,form='formatted') c OPEN(ifile(1)+4,file='xpresnord'//chr2,form='formatted') c OPEN(ifile(1)+6,file='xpm2'//chr2,form='formatted') ENDIF IF(latcal) THEN c OPEN(ifile(2)+14,file='xlats'//chr2,form='formatted') c OPEN(ifile(1)+14,file='xlatn'//chr2,form='formatted') ENDIF IF(lvent) THEN c OPEN(ifile(1)+16,file='xu1'//chr2,form='formatted') c OPEN(ifile(2)+16,file='xu2'//chr2,form='formatted') c OPEN(ifile(1)+12,file='xv1'//chr2,form='formatted') c OPEN(ifile(2)+12,file='xv2'//chr2,form='formatted') ENDIF OPEN(97,file='xprestot'//chr2,form='formatted') c OPEN(98,file='xlat37_'//chr2,form='formatted') WRITE(98,'(f5.1,16f7.1)') 0.,(rlonv(i)*180./pi,i=1,iim,4) ENDIF sollong=sollong*180./pi IF(day_ls) THEN dayw=sol ELSE dayw=sollong ENDIF c Calcul de la moyenne planetaire c ------------------------------- pstot=0. DO j=1,jjp1 DO i=1,iim pstot=pstot+aire(i,j)*ps(i,j) ENDDO ENDDO WRITE(97,'(2e16.6)') dayw,pstot*airtot1 IF(.NOT.firstcal) THEN WRITE(98,'(f5.1,16f7.3)') s dayw,(ps(i,37),i=1,iim,4) c boucle sur les sites vikings: c ---------------------------- DO iv=1,2 c interpollation de la temperature dans la 3eme couche, de la pression c de surface et des vents aux points viking. zp1=0. zp2=0. zt=0. zu=0. zv=0. DO jj=0,1 j=jvik(iv)+jj DO ii=0,1 i=ivik(iv)+ii zt=zt+zw(ii,jj,iv)*t(i,j,3) zp1=zp1+zw(ii,jj,iv)*ps(i,j) zu=zu+zw(ii,jj,iv)*unat(i,j,1)/cu(i,j) zv=zv+zw(ii,jj,iv)*vnat(i,j,1)/cv(i,j) ENDDO ENDDO c pression au sol extrapolee a partir de la temp. 3eme couche gh=r*zt zp2=zp1*exp(-(phivik(iv)-phisim(iv))/gh) WRITE (*,*) 'zp2, zp1, phivik(iv),phisim(iv),gh' WRITE (*,*) zp2, zp1, phivik(iv),phisim(iv),gh WRITE(ifile(iv)+10,'(2e15.5)') dayw,zp2 c deuxieme calcul: echelle de hauteur a 200K gh=r*200. zp2=zp1*exp(-(phivik(iv)-phisim(iv))/gh) WRITE(ifile(iv)+8,'(2e15.5)') dayw,zp2 c sorties eventuelles de vent IF(lvent) THEN WRITE(ifile(iv)+16,'(2e15.5)') s dayw,zu WRITE(ifile(iv)+12,'(2e15.5)') s dayw,zv ENDIF ENDDO IF (lcal) THEN WRITE(ifile(1)+4,'(2e15.6)') dayw,airtot1*g*.01* s (SSUM(ip1jmp1/2,ziceco2,1)-SSUM(jjp1/2,ziceco2,iip1)) WRITE(ifile(2)+4,'(2e15.6)') dayw,airtot1*g*.01* s (SSUM(iip1*jjm/2,ziceco2(1,jjm/2+2),1)- s SSUM(jjm/2,ziceco2(1,jjm/2+2),iip1)) ENDIF c IF(latcal) THEN c CALL icelat(iim,jjm,ziceco2,rlatv,zicelat) c WRITE(ifile(1)+14,'(2e15.6)') dayw,zicelat(1)*180./pi c WRITE(ifile(2)+14,'(2e15.6)') dayw,zicelat(2)*180./pi c ENDIF ENDIF firstcal=.false. c====================================================================== c Fin de la boucle sur les etats du fichier histoire: c====================================================================== ENDDO ierr=cllun(unitlec) PRINT*,'Fin du fichier',nomfich print*,'Entrer un nouveau fichier ou return pour finir' READ(5,'(a)',err=9999) nomfich c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% c Fin de la boucle sur les fichiers histoire: c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ENDDO 9999 PRINT*,'Fin ' PRINT*,'relief du point V1',.001*phis(ivik(1),jvik(1))/g PRINT*,'relief du point V2',.001*phis(ivik(2),jvik(2))/g DO iv=1,2 PRINT*,'Viking',iv,' i=',ivik(iv),'j =',jvik(iv) WRITE(6,7777) s (rlonv(i)*180./pi,i=ivik(iv)-1,ivik(iv)+2) print* DO j=jvik(iv)-1,jvik(iv)+2 WRITE(6,'(f8.1,10x,5f7.1)') s rlatu(j)*180./pi,(phis(i,j)/(g*1000.),i=ivik(iv)-1,ivik(iv)+2) ENDDO print* print*,'zw' write(6,'(2(2f10.4/))') ((zw(ii,jj,iv),ii=0,1),jj=0,1) print*,'altiude interpollee (km) ',phisim(iv)/1000./g ENDDO PRINT*,'R=',r 7777 FORMAT ('latitude/longitude',4f7.1) END