*=*=*=*= makelim.html =*=*=*=*
PROGRAM makelim

PROGRAM makelim


      PROGRAM makelim
c
c-------------------------------------------------------------
C Author : L. Fairhead
C Date   : 27/01/94
C Objet  : Construction des fichiers de conditions aux limites
C          (sst et albedo) pour le nouveau
C          modele a partir de fichiers de climatologie. Les deux
C          grilles doivent etre regulieres
c-------------------------------------------------------------
c
      implicit none
#include "dimensions.h"
#include "paramet.h"
#include "control.h"
#include "logic.h"
#include "drsdef.h"
#include "comvert.h"
#include "comgeom2.h"
#include "comconst.h"

C Declarations pour le champ de depart
      INTEGER imdep, jmdep,lmdep
      INTEGER ibid, jbid, lbid
      parameter (ibid = 500,
     .           jbid = 500,
     .           lbid = 500)
      REAL champ(ibid*jbid)
      REAL dlon(ibid), dlat(jbid), timecoord(lbid)
      REAL tcoord(366)

C Declarations pour le champ interpole 2D
      REAL champint(iim,jjp1)

C Declarations pour le champ interpole 3D
      REAL champtime(iim,jjp1,60)
      REAL champan(iip1,jjp1,366)

C Declarations pour l'inteprolation verticale
      REAL ax(lbid), ay(lbid)
      REAL by
      REAL yder(lbid)

C Declarations liees a la description des variables (setname)
      character varsource*120
      character varname*16, vartitle*80
      character varunits*40, vartype*8
      character vardate*8, vartime*8
      character dimsource*120
      character dimname*16, dimtitle*80
      character dimunits*40, dimtype*8
      character*80 drsname

C Declaration DRS
      INTEGER aslun, setname, putdat, cllun, cluvdb
      INTEGER inqdict, getname, getcdim
      INTEGER setvdim, setdim, getslab, putvdim
      INTEGER ierr
      INTEGER ibid
      INTEGER datadic, datadat, intdic, intdat
      parameter (datadic = 10, datadat = 11)
      parameter (intdic = 20, intdat = 21)
      REAL dimfirst(3)
      REAL dimlast(3)
      REAL dimcycl(3)
      INTEGER dimord(3)
      INTEGER vardim(3)

c Declarations pour les variables mises dans le fichier DRS
      INTEGER length
      parameter (length = 100)

      INTEGER icount
      INTEGER iix(200000), jjx(200000), ix(200000), jx(200000)
      REAL sx(200000),airnx(200000)
      INTEGER i, j, numdim, k, l
      REAL rlatu(jjp1), rlonv(iip1)
      REAL daysec, dtvr
c Diverses variables locales
      REAL nivmer
      REAL pi
      REAL time
      REAL timdeb, timfin
      INTEGER inttime
      REAL fract
      INTEGER an, mois, jour
      logical ldrs
      INTEGER it1, it2
      REAL polenord, polesud
#include "serre.h"
#include "fxyprim.h"

      pi     = 4. * atan(1.)
      nivmer = 0.
      ldrs   = .true.
      rad    = 6400000.
      omeg   = 4.*asin(1.)/(24.*3600.)
      g      = 9.8
      daysec = 86400.
c
c    ######  P. Le Van  ( Modif le  21/11/95 )     #######
c     pour avoir R = 287.059 et CP = 1004.70 , comme dans  physiq.F

      mugaz = 28.9645
      kappa = 0.285716

      call iniconst
      call inigeom

C Lecture fichier limite
      write(6,'(a,$)')'Fichier SST a lire ? : '
      read (5,'(a)')drsname
      ierr = ASLUN(datadic,drsname,datadat,' ',IDRS_READ)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier a interpoler '
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif

C Determination des dates de debut et de fin
      write(6,'(a,$)')' Date de debut souhaitee (an/mois/jour)? : '
      read(5,*) an, mois, jour
      call juldate(an, mois, jour, 12., 0., 0., timdeb, fract)
      timdeb = timdeb + fract
      write(6,'(a,$)')' Date de fin souhaitee (an/mois/jour)? : '
      read(5,*) an, mois, jour
      call juldate(an, mois, jour, 12., 0., 0., timfin, fract)
      timfin = timfin + fract
      write(6,'(a,2f16.3)')' Dates : ', timdeb, timfin
      inttime = int (timfin - timdeb) + 1
      tcoord(1) = timdeb - 2451545.
      do i = 2, inttime
        tcoord(i) = tcoord(i-1) + 1.
      enddo

C Ouverture fichier interpole
      write(6,'(a,$)')'Fichier de sortie? : '
      read (5,'(a)')drsname
      ierr = ASLUN(intdic,drsname,intdat,' ',IDRS_CREATE)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier interpole '
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif
C Ecriture des coordonnees dans le fichier interpole
      ierr = CLUVDB()
      ierr = SETNAME(' ','longitude',' Longitudes','degres',' ')
      ierr = PUTVDIM(intdic,iip1,rlonv,it1,it2)
      ierr = CLUVDB()
      ierr = SETNAME(' ','latitude',' Latitudes','degres',' ')
      ierr = PUTVDIM(intdic,jjp1,rlatu,it1,it2)
      do i = 1, inttime
        ierr = CLUVDB()
        ierr = SETNAME(' ','time',' Date','jour julien cf 2000.',' ')
        ierr = PUTVDIM(intdic,1,tcoord(i),it1,it2)
      enddo

C Traitement de la sst
      ierr = cluvdb()
      ierr = SETNAME(' ','SST',' ',' ',' ')
      ierr = INQDICT(datadic, IDRS_GETFIRSTVAR)
      ierr = GETNAME(varsource,varname,vartitle,varunits,vardate,
     .                 vartime,vartype, numdim)
      ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid, dlon, imdep)
      dimfirst(1) = dlon(1)
      dimlast (1) = dlon(imdep)
      dimcycl (1) = 0.
      dimord(1) = 1
      vardim(1) = imdep
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      dimfirst(2) = dlat(1)
      dimlast (2) = dlat(jmdep)
      dimcycl(2)  = 0.
      dimord(2) = 2
      vardim(2) = jmdep
      ierr = GETCDIM(3, dimsource, dimname, dimtitle, dimunits,
     .               dimtype, lbid, timecoord, lmdep)
      dimord(3) = 3
      dimcycl(3) = 0.
      vardim(3) = lmdep
      if (timdeb.lt.timecoord(1).or.timdeb.gt.timecoord(lmdep)
     .  .or.timfin.lt.timecoord(1).or.timfin.gt.timecoord(lmdep)) then
        write(6,*)' Probleme sur les intervalles de date : '
        write(6,*)' timdeb, timfin : ', timdeb, timfin
        write(6,*)' Intervalle du fichier lu: ',timecoord(1),
     .                                          timecoord(lmdep)
        write(6,*)' Je m''arrete'
        stop
      endif
      do l = 1, lmdep
        print*,' lecture et int. vert. ',l
        dimfirst(3) = timecoord(l)
        dimlast(3) = timecoord(l)
C on va chercher une tranche temporelle de la sst
        ierr = getslab(datadic, 3, dimord, dimfirst, dimlast,
     .               dimcycl, champ, vardim)
c       if (l.eq.1) write(60,*) (champ(i),i=1,imdep*jmdep)
C interpolation horizontale
        call linearb(imdep, jmdep, dlon, dlat,
     .             iim, jjp1, rlonv, rlatu,
     .             iix, jjx, ix, jx, sx, airnx, icount)
        call linear(imdep, jmdep, iim, jjp1,
     .            champ, champint,
     .            icount, iix, jjx, ix, jx, sx, airnx)
c       if (l.eq.1) write(61,*)((champint(i,j),i=1,iim),j=1,jjp1)
        do j = 1,jjp1
          do i = 1, iim
            champtime (i, j, l) = champint(i, j)
          enddo
        enddo
      enddo
C interpolation temporelle
      do j = 1, jjp1
        do i = 1, iim
          do l = 1, lmdep
            ax(l) = timecoord(l) - 2451545.
            ay(l) = champtime (i, j, l)
          enddo
          if (j.eq.24.and.i.eq.32)  then
c            write(63,*) 'ax'
c            write(63,112) (ax(l), l =1, lmdep)
 112         format(f16.3)
c            write(63,*) 'ay'
c            write(63,112)(ay(l), l =1, lmdep)
          endif
          call SPLINE(ax,ay,lmdep,1e30,1.e30,yder)
          do k = 1, inttime
            time = tcoord(k)
c           if (j.eq.24.and.i.eq.32) write(63,*)
c    .                   'lmdep ',lmdep,
c    .                   'time ',time
            call SPLINT(ax,ay,yder,lmdep,time,by)
            champan(i,j,k) = by
          enddo
        enddo
      enddo
c     polenord = 0.
c     polesud = 0.
      do k = 1, inttime
c       do i = 1, iim
c         polenord = polenord + champan (i, 1, k)
c         polesud = polesud + champan (i, jjp1, k)
c       enddo
c       polenord = polenord / iim
c       polesud = polesud / iim
        do j = 1, jjp1
c         do i = 1, iim
c           if (j .eq. 1) then
c             champan(i, j, k) = polenord
c           else if (j .eq. jjp1) then
c             champan(i, j, k) = polesud
c           else
c             champan(i, j, k) = champan (i, j, k)
c           endif
c         enddo
          champan(iip1, j, k) = champan(1, j, k)
        enddo
      enddo
c     write(62,*)((champan(i,j,1),i=1,iip1),j=1,jjp1)
c     write(64,*)((champan(i,j,2),i=1,iip1),j=1,jjp1)

C Ecriture DRS
      ierr = CLUVDB()
      ierr = SETVDIM(1,' ','longitude',' ',' ',rlonv(1), rlonv(iip1))
      ierr = SETVDIM(2,' ','latitude',' ',' ',rlatu(1), rlatu(jjp1))
      ierr = setvdim(3,' ','time',' ',' ',tcoord(1), tcoord(inttime))
      ierr = SETNAME(varsource,'SST','SST interpolee',varunits,vartype)
      ierr = putdat(intdic, champan)

      ierr = cllun(datadic)


C Lecture fichier limite
      write(6,'(a,$)')'Fichier conditions a lire ? : '
      read (5,'(a)')drsname
      ierr = ASLUN(datadic,drsname,datadat,' ',IDRS_READ)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier a interpoler '
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif

C Traitement de l'albedo
      ierr = cluvdb()
      ierr = SETNAME(' ','AL',' ',' ',' ')
      ierr = INQDICT(datadic, IDRS_GETFIRSTVAR)
      ierr = GETNAME(varsource,varname,vartitle,varunits,vardate,
     .                 vartime,vartype, numdim)
      ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid, dlon, imdep)
      dimfirst(1) = dlon(1)
      dimlast (1) = dlon(imdep)
      dimcycl (1) = 0.
      dimord(1) = 1
      vardim(1) = imdep
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      dimfirst(2) = dlat(1)
      dimlast (2) = dlat(jmdep)
      dimcycl(2)  = 0.
      dimord(2) = 2
      vardim(2) = jmdep
      ierr = GETCDIM(3, dimsource, dimname, dimtitle, dimunits,
     .               dimtype, lbid, timecoord, lmdep)
      dimord(3) = 3
      dimcycl(3) = 0.
      vardim(3) = lmdep
      if (timdeb.lt.timecoord(1).or.timdeb.gt.timecoord(lmdep)
     .  .or.timfin.lt.timecoord(1).or.timfin.gt.timecoord(lmdep)) then
        write(6,*)' Probleme sur les intervalles de date : '
        write(6,*)' timdeb, timfin : ', timdeb, timfin
        write(6,*)' Intervalle du fichier lu: ',timecoord(1),
     .                                          timecoord(lmdep)
        write(6,*)' Je m''arrete'
        stop
      endif
      do l = 1, lmdep
        print*,' lecture et int. vert. ',l
        dimfirst(3) = timecoord(l)
        dimlast(3) = timecoord(l)
C on va chercher une tranche temporelle de l'albedo
        ierr = getslab(datadic, 3, dimord, dimfirst, dimlast,
     .               dimcycl, champ, vardim)
c       if (l.eq.1) write(70,*) (champ(i),i=1,imdep*jmdep)
C interpolation horizontale
        call linearb(imdep, jmdep, dlon, dlat,
     .             iim, jjp1, rlonv, rlatu,
     .             iix, jjx, ix, jx, sx, airnx, icount)
        call linear(imdep, jmdep, iim, jjp1,
     .            champ, champint,
     .            icount, iix, jjx, ix, jx, sx, airnx)
c       if (l.eq.1) write(71,*)((champint(i,j),i=1,iim),j=1,jjp1)
        do j = 1,jjp1
          do i = 1, iim
            champtime (i, j, l) = champint(i, j)
          enddo
        enddo
      enddo
C interpolation temporelle
      do j = 1, jjp1
        do i = 1, iim
          do l = 1, lmdep
            ax(l) = timecoord(l) - 2451545.
            ay(l) = champtime (i, j, l)
          enddo
c         if (j.eq.24.and.i.eq.32)  then
c            write(73,*) 'ax'
c            write(73,112) (ax(l), l =1, lmdep)
c            write(73,*) 'ay'
c            write(73,112)(ay(l), l =1, lmdep)
c         endif
          call SPLINE(ax,ay,lmdep,1e30,1.e30,yder)
          do k = 1, inttime
            time = tcoord(k)
c           if (j.eq.24.and.i.eq.32) write(73,*)
c    .                   'lmdep ',lmdep,
c    .                   'time ',time
            call SPLINT(ax,ay,yder,lmdep,time,by)
            champan(i,j,k) = by
          enddo
        enddo
      enddo
c     polenord = 0.
c     polesud = 0.
      do k = 1, inttime
c       do i = 1, iim
c         polenord = polenord + champan (i, 1, k)
c         polesud = polesud + champan (i, jjp1, k)
c       enddo
c       polenord = polenord / iim
c       polesud = polesud / iim
        do j = 1, jjp1
c         do i = 1, iim
c           if (j .eq. 1) then
c             champan(i, j, k) = polenord
c           else if (j .eq. jjp1) then
c             champan(i, j, k) = polesud
c           else
c             champan(i, j, k) = champan (i, j, k)
c           endif
c         enddo
          champan(iip1, j, k) = champan(1, j, k)
        enddo
      enddo
c     write(72,*)((champan(i,j,1),i=1,iip1),j=1,jjp1)
c     write(74,*)((champan(i,j,2),i=1,iip1),j=1,jjp1)


C Ecriture DRS
      ierr = CLUVDB()
      ierr = SETVDIM(1,' ','longitude',' ',' ',rlonv(1), rlonv(iip1))
      ierr = SETVDIM(2,' ','latitude',' ',' ',rlatu(1), rlatu(jjp1))
      ierr = setvdim(3,' ','time',' ',' ',tcoord(1), tcoord(inttime))
      ierr = SETNAME(varsource,'AL','Albedo interpolee','-',vartype)
      ierr = putdat(intdic, champan)

      ierr = cllun(datadic)
      ierr = cllun(intdic)
      end