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

PROGRAM makelim


      PROGRAM makelim
      IMPLICIT none
c
c-------------------------------------------------------------
C Author : L. Fairhead
C Date   : 27/01/94
C Objet  : Construction des fichiers de conditions aux limites
C          pour le nouveau
C          modele a partir de fichiers de climatologie. Les deux
C          grilles doivent etre regulieres
c
c Modifie par z.x.li (le23mars1994)
c-------------------------------------------------------------
c
#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
c-----------------------------------------------------------------------
      INTEGER KIDIA, KFDIA, KLON, KLEV
      PARAMETER (KIDIA=1,KFDIA=iim*(jjm-1)+2,
     .           KLON=KFDIA-KIDIA+1,KLEV=llm)
c-----------------------------------------------------------------------
      REAL phy_nat(klon,360), phy_nat0(klon)
      REAL phy_alb(klon,360)
      REAL phy_sst(klon,360)
      REAL phy_bil(klon,360)
      REAL phy_rug(klon,360)
      REAL phy_ice(klon,360)
c
      REAL masque(iip1,jjp1)
      REAL mask(iim,jjp1)

C Declarations pour le champ de depart
      INTEGER imdep, jmdep,lmdep
      INTEGER ibid, jbid, tbid
      parameter (ibid = 400,       ! >360 pts
     .           jbid = 200,       ! >181 pts
     .           tbid = 60)        ! >52 semaines
      REAL champ(ibid*jbid)
      REAL dlon(ibid), dlat(jbid), timecoord(tbid)
c
      INTEGER ibid_msk, jbid_msk
      PARAMETER(ibid_msk=2200,jbid_msk=1100)
      REAL champ_msk(ibid_msk*jbid_msk)
      REAL dlon_msk(ibid_msk), dlat_msk(jbid_msk)

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

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

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

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 getdat
      INTEGER ierr
      INTEGER datadic, datadat
      parameter (datadic = 10, datadat = 11)
      INTEGER intdic, intdat
      PARAMETER (intdic=20, intdat=21)
      INTEGER ecdicdyn, ecdatdyn
      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 i, j, numdim, k, l
c Diverses variables locales
      REAL time
      REAL timdeb, timfin
      REAL fract
      INTEGER an, mois, jour
      INTEGER it1, it2
#include "serre.h"
#include "fxyprim.h"

c initialisations:
      OPEN (8,file='run.def',form='formatted')
      CALL defrun_new( 8, .TRUE. )
      CLOSE(8)

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

      mugaz = 28.9645
      kappa = 0.285716
c
      dtvr    = daysec/FLOAT(day_step)
c
      call iniconst
      call inigeom
c
c
C Traitement du relief au sol
c
      PRINT*, 'Traitement du relief au sol pour fabriquer masque'
      ierr = ASLUN(datadic,'relief',datadat,' ',IDRS_READ)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier relief'
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','RELIEF',' ',' ',' ')
      ierr = INQDICT(datadic, IDRS_GETFIRSTVAR)
      ierr = GETCDIM(1, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,ibid_msk, dlon_msk, imdep)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid_msk, dlat_msk, jmdep)
      ierr=GETDAT(datadic,champ_msk,imdep*jmdep*IDRS_BYTES_PER_WORD)
      ierr = CLLUN(datadic)
c
      CALL mask_c_o(imdep, jmdep, dlon_msk, dlat_msk,champ_msk,
     .             iim, jjp1, rlonv, rlatu, champint)
      CALL gr_int_dyn(champint, masque, iim, jjp1)
      DO i = 1, iim
         masque(i,1) = FLOAT(NINT(masque(i,1)))
         masque(i,jjp1) = FLOAT(NINT(masque(i,jjp1)))
      ENDDO
      DO i = 1, iim
      DO j = 1, jjp1
         mask(i,j) = champint(i,j)
      ENDDO
      ENDDO
      call gr_dyn_fi(1, iip1, jjp1, klon, masque, phy_nat0)
      ierr = CLLUN(datadic)
c
c
C Traitement de la rugosite
c
      PRINT*, 'Traitement de la rugosite'
      ierr = ASLUN(datadic,'rugos',datadat,' ',IDRS_READ)
      IF (ierr.ne.0) THEN
        write(6,*)' Pb d''ouverture du fichier rugos_1x1'
        write(6,*)' ierr = ', ierr
        call exit(1)
      ENDIF
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','RUGOS',' ',' ',' ')
      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)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      ierr = GETCDIM(3, dimsource, dimname, dimtitle, dimunits,
     .               dimtype, tbid, timecoord, lmdep)
      DO l = 1, lmdep
         dimfirst(1) = dlon(1)
         dimfirst(2) = dlat(1)
         dimfirst(3) = timecoord(l)
c
         dimlast(1) = dlon(imdep)
         dimlast(2) = dlat(jmdep)
         dimlast(3) = timecoord(l)
c
         dimcycl(1) = 0.
         dimcycl(2) = 0.
         dimcycl(3) = 0.
c
         dimord(1) = 1
         dimord(2) = 2
         dimord(3) = 3
c
         vardim(1) = imdep
         vardim(2) = jmdep
         vardim(3) = lmdep
         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
         ierr = GETSLAB(datadic, 3, dimord, dimfirst, dimlast,
     .               dimcycl, champ, vardim)
         CALL rugosite(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint, mask)
         DO j = 1,jjp1
         DO i = 1, iim
            champtime (i,j,l) = champint(i,j)
         ENDDO
         ENDDO
      ENDDO
c
      DO l = 1, lmdep
         timeyear(l) = timecoord(l)
      ENDDO
      print*, 'timeyear=', timeyear
c
      PRINT*, 'Interpolation temporelle dans l annee'
      DO j = 1, jjp1
      DO i = 1, iim
          DO l = 1, lmdep
            ax(l) = timeyear(l)
            ay(l) = champtime (i,j,l)
          ENDDO
          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
          DO k = 1, 360
            time = FLOAT(k-1)
            CALL SPLINT(ax,ay,yder,lmdep,time,by)
            champan(i,j,k) = by
          ENDDO
      ENDDO
      ENDDO
      DO k = 1, 360
      DO j = 1, jjp1
         champan(iip1,j,k) = champan(1,j,k)
      ENDDO
      ENDDO
c
      DO k = 1, 360
         CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k))
      ENDDO
c
      ierr = CLLUN(datadic)
c
c
C Traitement de la glace oceanique
c
      PRINT*, 'Traitement de la glace oceanique'
      ierr = ASLUN(datadic,'amip',datadat,' ',IDRS_READ)
      IF (ierr.ne.0) THEN
        write(6,*)' Pb d''ouverture du fichier amip'
        write(6,*)' ierr = ', ierr
        call exit(1)
      ENDIF
c
      ierr = CLUVDB()
      ierr = SETNAME(' ','SEA_ICE',' ',' ',' ')
      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)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      ierr = GETCDIM(3, dimsource, dimname, dimtitle, dimunits,
     .               dimtype, tbid, timecoord, lmdep)
      DO l = 1, lmdep
         dimfirst(1) = dlon(1)
         dimfirst(2) = dlat(1)
         dimfirst(3) = timecoord(l)
c
         dimlast(1) = dlon(imdep)
         dimlast(2) = dlat(jmdep)
         dimlast(3) = timecoord(l)
c
         dimcycl(1) = 0.
         dimcycl(2) = 0.
         dimcycl(3) = 0.
c
         dimord(1) = 1
         dimord(2) = 2
         dimord(3) = 3
c
         vardim(1) = imdep
         vardim(2) = jmdep
         vardim(3) = lmdep
         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
         ierr = GETSLAB(datadic, 3, dimord, dimfirst, dimlast,
     .               dimcycl, champ, vardim)
         CALL sea_ice(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
         DO j = 1,jjp1
         DO i = 1, iim
            champtime (i,j,l) = champint(i,j)
         ENDDO
         ENDDO
      ENDDO
c
      DO l = 1, lmdep
         timeyear(l) = timecoord(l)
      ENDDO
      PRINT*, 'timeyear=', timeyear
c
      PRINT*, 'Interpolation temporelle'
      DO j = 1, jjp1
      DO i = 1, iim
          DO l = 1, lmdep
            ax(l) = timeyear(l)
            ay(l) = champtime (i,j,l)
          ENDDO
          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
          DO k = 1, 360
            time = FLOAT(k-1)
            CALL SPLINT(ax,ay,yder,lmdep,time,by)
            champan(i,j,k) = by
          ENDDO
      ENDDO
      ENDDO
      DO k = 1, 360
      DO j = 1, jjp1
         champan(iip1, j, k) = champan(1, j, k)
      ENDDO
      ENDDO
c
c
c  ....  Modif  P.Le Van  ( 1/09/95  )  ...
c
      DO k = 1, 360
         CALL gr_dyn_fi(1, iip1, jjp1, klon,
     .                  champan(1,1,k), phy_ice(1,k))
         DO i = 1, klon
            phy_nat(i,k) = phy_nat0(i)
            IF ( (phy_ice(i,k) - 0.5).GE.1.e-5 ) THEN
               IF (NINT(phy_nat0(i)).EQ.0) THEN
                  phy_nat(i,k) = 3.0
               ELSE
                  phy_nat(i,k) = 2.0
               ENDIF
            ENDIF
         ENDDO
      ENDDO
c
      ierr = CLLUN(datadic)
c
c
C Traitement de la sst
c
      PRINT*, 'Traitement de la sst'
      ierr = ASLUN(datadic,'amip',datadat,' ',IDRS_READ)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier amip'
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif
c
      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)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      ierr = GETCDIM(3, dimsource, dimname, dimtitle, dimunits,
     .               dimtype, tbid, timecoord, lmdep)
      do l = 1, lmdep
         dimfirst(1) = dlon(1)
         dimfirst(2) = dlat(1)
         dimfirst(3) = timecoord(l)
c
         dimlast(1) = dlon(imdep)
         dimlast(2) = dlat(jmdep)
         dimlast(3) = timecoord(l)
c
         dimcycl(1) = 0.
         dimcycl(2) = 0.
         dimcycl(3) = 0.
c
         dimord(1) = 1
         dimord(2) = 2
         dimord(3) = 3
c
         vardim(1) = imdep
         vardim(2) = jmdep
         vardim(3) = lmdep
         PRINT*,'Lecture temporelle et int. horizontale',l,timecoord(l)
         ierr = GETSLAB(datadic, 3, dimord, dimfirst, dimlast,
     .               dimcycl, champ, vardim)
         CALL grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)

         DO j = 1,jjp1
         DO i = 1, iim
            champtime (i,j,l) = champint(i,j)
         ENDDO
         ENDDO
      ENDDO
c
      DO l = 1, lmdep
         timeyear(l) = timecoord(l)
      ENDDO
      print*, 'timeyear=', timeyear
c
C interpolation temporelle
      DO j = 1, jjp1
      DO i = 1, iim
          DO l = 1, lmdep
            ax(l) = timeyear(l)
            ay(l) = champtime (i,j,l)
          ENDDO
          CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
          DO k = 1, 360
            time = FLOAT(k-1)
            CALL SPLINT(ax,ay,yder,lmdep,time,by)
            champan(i,j,k) = by
          ENDDO
      ENDDO
      ENDDO
      DO k = 1, 360
      DO j = 1, jjp1
         champan(iip1,j,k) = champan(1,j,k)
      ENDDO
      ENDDO
c
      DO k = 1, 360
         CALL gr_dyn_fi(1, iip1, jjp1, klon,
     .                  champan(1,1,k), phy_sst(1,k))
      ENDDO
c
      ierr = CLLUN(datadic)
c
c
C Traitement de l'albedo
c
      PRINT*, 'Traitement de l albedo'
      ierr = ASLUN(datadic,'albed',datadat,' ',IDRS_READ)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier albed'
        write(6,*)' ierr = ', ierr
        call exit(1)
      endif
c
      ierr = cluvdb()
      ierr = SETNAME(' ','ALBEDO',' ',' ',' ')
      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)
      ierr = GETCDIM(2, dimsource, dimname, dimtitle, dimunits,
     .               dimtype,jbid, dlat, jmdep)
      ierr = GETCDIM(3, dimsource, dimname, dimtitle, dimunits,
     .               dimtype, tbid, timecoord, lmdep)
      DO l = 1, lmdep
         dimfirst(1) = dlon(1)
         dimfirst(2) = dlat(1)
         dimfirst(3) = timecoord(l)
c
         dimlast (1) = dlon(imdep)
         dimlast (2) = dlat(jmdep)
         dimlast(3) = timecoord(l)
c
         dimcycl (1) = 0.
         dimcycl(2)  = 0.
         dimcycl(3) = 0.
c
         dimord(1) = 1
         dimord(2) = 2
         dimord(3) = 3
c
         vardim(1) = imdep
         vardim(2) = jmdep
         vardim(3) = lmdep
         PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l)
         ierr = GETSLAB(datadic, 3, dimord, dimfirst, dimlast,
     .               dimcycl, champ, vardim)
         CALL grille_m(imdep, jmdep, dlon, dlat, champ,
     .             iim, jjp1, rlonv, rlatu, champint)
c
         DO j = 1,jjp1
         DO i = 1, iim
            champtime (i, j, l) = champint(i, j)
         ENDDO
         ENDDO
      ENDDO
c
      DO l = 1, lmdep
         timeyear(l) = timecoord(l)
      ENDDO
      print*, 'timeyear=', timeyear
c
C interpolation temporelle
      DO j = 1, jjp1
      DO i = 1, iim
          DO l = 1, lmdep
            ax(l) = timeyear(l)
            ay(l) = champtime (i, j, l)
          ENDDO
          call SPLINE(ax,ay,lmdep,1.e30,1.e30,yder)
          DO k = 1, 360
            time = FLOAT(k-1)
            call SPLINT(ax,ay,yder,lmdep,time,by)
            champan(i,j,k) = by
          ENDDO
      ENDDO
      ENDDO
      DO k = 1, 360
      DO j = 1, jjp1
         champan(iip1, j, k) = champan(1, j, k)
      ENDDO
      ENDDO
c
      DO k = 1, 360
         call gr_dyn_fi(1, iip1, jjp1, klon,
     .                  champan(1,1,k), phy_alb(1,k))
      ENDDO
c
      ierr = CLLUN(datadic)
c
c
c
c
      PRINT*, 'Ecriture du fichier limit'
      ierr = ASLUN(intdic,'limit',intdat,' ',IDRS_CREATE)
      if (ierr.ne.0) then
        write(6,*)' Pb d''ouverture du fichier'
        write(6,*)' ierr = ', ierr
        CALL ABORT
      endif
c
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'NAT', 'nature_sol', ' ', ' ')
      ierr = SETDIM(1, 'points_physiques', ' ',
     .              klon, 1.0, float(klon))
      ierr = SETDIM(2, 'jours_dans_l_annee', ' ',
     .              360, 0.0, 359.0)
      ierr = PUTDAT(intdic, phy_nat)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'SST', 'temperature', 'Kelvin', ' ')
      ierr = SETDIM(1, 'points_physiques', ' ',
     .              klon, 1.0, float(klon))
      ierr = SETDIM(2, 'jours_dans_l_annee', ' ',
     .              360, 0.0, 359.0)
      ierr = PUTDAT(intdic, phy_sst)
c
      DO k = 1, 360
      DO i = 1, klon
         phy_bil(i,k) = 0.0
      ENDDO
      ENDDO
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'BILS', 'bilan au sol', 'W/m**2', ' ')
      ierr = SETDIM(1, 'points_physiques', ' ',
     .              klon, 1.0, float(klon))
      ierr = SETDIM(2, 'jours_dans_l_annee', ' ',
     .              360, 0.0, 359.0)
      ierr = PUTDAT(intdic, phy_bil)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'ALB', 'albedo', ' ', ' ')
      ierr = SETDIM(1, 'points_physiques', ' ',
     .              klon, 1.0, float(klon))
      ierr = SETDIM(2, 'jours_dans_l_annee', ' ',
     .              360, 0.0, 359.0)
      ierr = PUTDAT(intdic, phy_alb)
c
      ierr = CLUVDB()
      ierr = SETNAME(' ', 'RUG', 'rugosite', ' ', ' ')
      ierr = SETDIM(1, 'points_physiques', ' ',
     .              klon, 1.0, float(klon))
      ierr = SETDIM(2, 'jours_dans_l_annee', ' ',
     .              360, 0.0, 359.0)
      ierr = PUTDAT(intdic, phy_rug)
c
      ierr = CLLUN(intdic)
c
      STOP
      END