*=*=*=*= xvik.html =*=*=*=*
PROGRAM xvik

PROGRAM xvik


      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