*=*=*=*= makelim.html =*=*=*=*
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