SUBROUTINE get_uvd(itap,dtime,tsol,qsol,file_fordat s ,ht,hq,hw) implicit none cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c cette routine permet d'obtenir u_convg,v_convg,ht,hq et ainsi de c pouvoir calculer la convergence et le cisaillement dans la physiq ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc #include "YOMCST.h" INTEGER klev REAL play(100) !pression en Pa au milieu de chaque couche GCM INTEGER JM(100) !pression en Pa au milieu de chaque couche GCM REAL coef1(100) !coefficient d'interpolation REAL coef2(100) !coefficient d'interpolation INTEGER nblvlm !nombre de niveau de pression du mesoNH REAL playm(100) !pression en Pa au milieu de chaque couche Meso-NH REAL hplaym(100) !pression en hPa milieux des couches Meso-NH integer i,j,k,ii,ll,in REAL tsol,qsol CHARACTER*80 file_forctl,file_fordat,file_start COMMON/physiq1/klev,play,JM,coef1,coef2 COMMON/physiq2/nblvlm,playm,hplaym c====================================================================== c methode: on va chercher les donnees du mesoNH de meteo france, on y c a acces a tout pas detemps grace a la routine rdgrads qui c est une boucle lisant dans ces fichiers. c Puis on interpole ces donnes sur les 11 niveaux du gcm et c et sur les pas de temps de ce meme gcm c====================================================================== c input: c pasmax :nombre de pas de temps maximum du mesoNH c dt :pas de temps du meso_NH (en secondes) c---------------------------------------------------------------------- integer pasmax,dt save pasmax,dt c---------------------------------------------------------------------- c arguments: c itap :compteur de la physique(le nombre de ces pas est c fixe dans la subroutine calcul_ini_gcm de interpo c -lation c dtime :pas detemps du gcm (en secondes) c ht :convergence horizontale de temperature(K/s) c hq : " " d'humidite (kg/kg/s) c hw :vitesse verticale moyenne (m/s**2) c---------------------------------------------------------------------- integer itap real dtime real ht(100) real hq(100) real hw(100) c---------------------------------------------------------------------- c Variables internes de get_uvd (note : l'interpolation temporelle c est faite entre les pas de temps before et after, sur les variables c definies sur la grille du SCM) c time0 :date initiale en secondes c time :temps associe a chaque pas c pas :numero du pas du meso_NH c pasprev :numero du pas precedent c htaft :advection horizontale de temp. au pas de temps after c hqaft : " " d'humidite " c hwaft :vitesse verticalle moyenne au pas de temps after c htbef :idem htaft, mais pour le pas de temps before c hqbef :voir hqaft c hwbef :voir hwaft c---------------------------------------------------------------------- integer time0,pas,pasprev save time0,pas,pasprev real time real htaft(100),hqaft(100),hwaft(100) save htaft,hqaft,hwaft real htbef(100),hqbef(100),hwbef(100) save htbef,hqbef,hwbef integer timeaft,timebef save timeaft,timebef integer temps character*4 string c---------------------------------------------------------------------- c variables arguments de la subroutine rdgrads c--------------------------------------------------------------------- integer icompt !compteur de rdgrads real z(100) ! altitude (grille Meso) real ht_mes(100) !convergence horizontale de temperature !-(grille Meso) real hq_mes(100) !convergence horizontale d'humidite !(grille Meso) real hw_mes(100) !vitesse verticale moyenne !(grille Meso) c c--------------------------------------------------------------------- c variable argument de la subroutine copie c--------------------------------------------------------------------- c SB real pplay(100) !pression en milieu de couche du gcm c SB !argument de la physique c--------------------------------------------------------------------- c variables destinees a la lecture du pas de temps du fichier de donnees c--------------------------------------------------------------------- character*80 aaa,atemps,spaces,apasmax integer nch,imn,ipa c--------------------------------------------------------------------- c procedures appelees external rdgrads !lire en iterant dans forcing.dat c--------------------------------------------------------------------- print*,'le pas itap est:',itap c*** on determine le pas du meso_NH correspondant au nouvel itap *** c*** pour aller chercher les champs dans rdgrads *** time=time0+itap*dtime temps=int(time/dt+1) pas=min(temps,pasmax) print*,'le pas Meso est:',pas c c c=================================================================== c c*** on remplit les champs before avec les champs after du pas *** c*** precedent en format gcm *** if(pas.gt.pasprev)then do i=1,klev htbef(i)=htaft(i) hqbef(i)=hqaft(i) hwbef(i)=hwaft(i) enddo timebef=pasprev*dt timeaft=timebef+dt icompt=(pas-1)*(nblvlm*4) print*,'le pas pas est:',pas c*** on va chercher les nouveaux champs after dans toga.dat *** c*** champs en format meso_NH *** c open(99,FILE='forcing.dat',FORM='UNFORMATTED', write(*,'(a)') 'OPEN dans get_uvd de '//file_fordat open(99,FILE=file_fordat,FORM='UNFORMATTED', . ACCESS='DIRECT',RECL=4) call rdgrads(99,icompt,nblvlm,z,ht_mes,hq_mes,hw_mes) do i = 1,nblvlm ht_mes(i) = ht_mes(i)*(hplaym(i)/1000.)**rkappa enddo c print*,'ht_mes ',(ht_mes(i),i=1,nblvlm) print*,'hq_mes ',(hq_mes(i),i=1,nblvlm) print*,'hw_mes ',(hw_mes(i),i=1,nblvlm) c*** on interpole les champs meso_NH sur les niveaux de pression*** c*** gcm . on obtient le nouveau champ after *** do k=1,klev if (JM(k) .eq. 0) then htaft(k)=coef1(k)*tsol+coef2(k)*ht_mes(jm(k)+1) hqaft(k)=coef1(k)*qsol+coef2(k)*hq_mes(jm(k)+1) hwaft(k)= coef2(k)*hw_mes(jm(k)+1) else htaft(k)=coef1(k)*ht_mes(jm(k))+coef2(k)*ht_mes(jm(k)+1) hqaft(k)=coef1(k)*hq_mes(jm(k))+coef2(k)*hq_mes(jm(k)+1) hwaft(k)=coef1(k)*hw_mes(jm(k))+coef2(k)*hw_mes(jm(k)+1) endif enddo pasprev=pas else print*,'timebef est:',timebef endif !fin du bloc relatif au passage au pas !de temps (meso) suivant c*** si on atteint le pas max des donnees experimentales ,on *** c*** on conserve les derniers champs calcules *** if(pas.ge.pasmax)then do ll=1,klev ht(ll)=htaft(ll) hq(ll)=hqaft(ll) hw(ll)=hwaft(ll) enddo else c*** on interpole sur les pas de temps de 10mn du gcm a partir *** c** des pas de temps de 1h du meso_NH *** do j=1,klev ht(j)=((timeaft-time)*htbef(j)+(time-timebef)*htaft(j))/dt hq(j)=((timeaft-time)*hqbef(j)+(time-timebef)*hqaft(j))/dt hw(j)=((timeaft-time)*hwbef(j)+(time-timebef)*hwaft(j))/dt enddo endif c c------------------------------------------------------------------- c return c c----------------------------------------------------------------------- c on sort les champs de "convergence" pour l'instant initial 'in' c ceci se passe au pas temps itap=0 de la physique c----------------------------------------------------------------------- entry get_uvd2(itap,file_forctl,file_fordat,file_start s ,ht,hq,hw) print*,'le pas itap est:',itap c c=================================================================== c write(*,*) ' ' write(*,*) 'FICHIERS A LIRE DANS GET_UVD2: ' write(*,'(a)') 'fichier forcing.ctl: '//file_forctl write(*,'(a)') 'fichier forcing.dat: '//file_fordat write(*,'(a)') 'fichier start18.data: '//file_start write(*,*) ' ' c!! en attendant de pouvoir compiler les fns CERN, en prescrit c!! les variables imn et pasmax a la main... c!! write(*,'(a)') 'OPEN '//file_forctl open(97,FILE=file_forctl,FORM='FORMATTED') c c------------------ do i=1,1000 read(97,1000,end=999) string 1000 format (a4) if (string .eq. 'TDEF') go to 50 enddo 50 backspace(97) c------------------------------------------------------------------- c *** on lit le pas de temps dans le fichier de donnees *** c *** "forcing.ctl" et pasmax *** c------------------------------------------------------------------- read(97,2000) aaa 2000 format (a80) print*,'aaa est',aaa aaa=spaces(aaa,1) print*,'aaa',aaa call getsch(aaa,' ',' ',5,atemps,nch) print*,'atemps est',atemps atemps=atemps(1:nch-2) print*,'atemps',atemps read(atemps,*) imn dt=imn*60 print*,'le pas de temps dt',dt call getsch(aaa,' ',' ',2,apasmax,nch) apasmax=apasmax(1:nch) read(apasmax,*) ipa pasmax=ipa print*,'pasmax est',pasmax CLOSE(97) c CASE_E: c!! imn = 60 c!! ipa = 8 c TOGA: c!! imn = 360 c!! ipa = 480 dt=imn*60 pasmax=ipa print*,'le pas de temps dt',dt print*,'pasmax est',pasmax c------------------------------------------------------------------ c *** onlit le pas de temps initial de la simulation dans *** c *** "start.data" *** c------------------------------------------------------------------ c open(98,file='start18.data',form='formatted') write(*,'(a)') 'OPEN '//file_start open(98,FILE=file_start,FORM='FORMATTED') read(98,*)in pasprev=in print*,'le pas in ini est:',pasprev C Cjyg Correction de la date du demarrage. CC time0=dt*pasprev time0=dt*(pasprev-1) C close(98) c c open(99,FILE='forcing.dat',FORM='UNFORMATTED', write(*,'(a)') 'OPEN '//file_fordat open(99,FILE=file_fordat,FORM='UNFORMATTED', . ACCESS='DIRECT',RECL=4) icompt=(in-1)*(nblvlm*4) call rdgrads(99,icompt,nblvlm,z,ht_mes,hq_mes,hw_mes) do i = 1,nblvlm ht_mes(i) = ht_mes(i)*(hplaym(i)/1000.)**rkappa enddo c print*,'ht_mes ',(ht_mes(i),i=1,nblvlm) print*,'hq_mes ',(hq_mes(i),i=1,nblvlm) print*,'hw_mes ',(hw_mes(i),i=1,nblvlm) c---------------------------------------------------------------------- c on a obtenu des champs initiaux sur les niveaux du meso_NH c on interpole sur les niveaux du gcm(niveau pression bien sur!) c----------------------------------------------------------------------- do ii=1,klev htaft(ii)=coef1(ii)*ht_mes(JM(ii))+coef2(ii)*ht_mes(JM(ii)+1) hqaft(ii)=coef1(ii)*hq_mes(JM(ii))+coef2(ii)*hq_mes(JM(ii)+1) hwaft(ii)=coef1(ii)*hw_mes(JM(ii))+coef2(ii)*hw_mes(JM(ii)+1) enddo c valeurs initiales des champs de convergence do k=1,klev ht(k)=htaft(k) hq(k)=hqaft(k) hw(k)=hwaft(k) enddo close(99) close(98) c c------------------------------------------------------------------- c 100 return c 999 continue stop 'erreur lecture, file forcing.ctl' end SUBROUTINE cool_pool(istep e ,n_cooling,dt_cooling,dq_cooling s ,dt_cool,dq_cool) implicit none C*************************************************************** C* * C* COOL_POOL * C* * C* * C* written by : Gilles Foret RAMSES, 15/09/97, 22.00.2 * C* modified by : Sandrine Bony 10/09/98 * C*************************************************************** c Arguments c ========= c Input c ----- c istep : numero du pas de temps c n_cooling: nbre de pas de temps ou la pertubation nominale c est appliquee (ensuite, la pertubation decroit c exponentiellement). c dt_cooling : pertubation nominale en temperature c dq_cooling : pertubation nominale en humidite c Output c ------ c dt_cool : pertubation en temperature c dq_cool : pertubation en humidite c c Variables internes c ================== c scale : facteur applique a la pertubation nominale c #include "dimensions.h" #include "dimphy.h" c integer n_cooling,k,istep real dt_cooling(klev),dq_cooling(klev),scale real dt_cool(klev),dq_cool(klev) c if (istep .le. n_cooling ) then scale = 1. else scale = 4**(min(15,istep-n_cooling)) endif c do k = 1,klev dt_cool(k) = dt_cooling(k)/scale dq_cool(k) = dq_cooling(k)/scale enddo c return end SUBROUTINE advect_tvl(dtime,t,q,vu_f,vv_f,t_f,q_f : ,d_t_adv,d_q_adv) implicit none #include "dimensions.h" #include "dimphy.h" integer k real dtime, fact, du, dv, cx, cy, alx, aly real t(klev), q(klev,3) : , vu_f(klev), vv_f(klev), t_f(klev), q_f(klev,3) real d_t_adv(klev), d_q_adv(klev,3) c Velocity of moving cell data cx,cy /12., -2./ c Dimensions of moving cell data alx,aly /100 000.,150 000./ do k = 1, klev du = abs(vu_f(k)-cx)/alx dv = abs(vv_f(k)-cy)/aly fact = dtime *(du+dv-du*dv*dtime) d_t_adv(k) = fact * (t_f(k)-t(k)) d_q_adv(k,1) = fact * (q_f(k,1)-q(k,1)) d_q_adv(k,2) = fact * (q_f(k,2)-q(k,2)) d_q_adv(k,3) = fact * (q_f(k,3)-q(k,3)) enddo return end SUBROUTINE copie(klevgcm,playgcm,psolgcm,file_forctl) implicit none ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c cette routine remplit les COMMON physiq1 et physiq2.h cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc INTEGER JM INTEGER klev !nombre de niveau de pression du GCM INTEGER nblvlm !nombre de niveau de pression du mesoNH REAL playm(100) !pression en Pa au milieu de chaque couche Meso-NH REAL hplaym(100)!pression en hecto-Pa des milieux de couche Meso-NH REAL play(100) !pression en Pa au milieu de chaque couche GCM REAL coef1(100) !coefficient d'interpolation REAL coef2(100) !coefficient d'interpolation COMMON/physiq1/klev,play,JM,coef1,coef2 COMMON/physiq2/nblvlm,playm,hplaym integer i,k,klevgcm real playgcm(klevgcm) ! pression en milieu de couche du gcm real psolgcm character*80 file_forctl klev = klevgcm c--------------------------------------------------------------------- c pression au milieu des couches du gcm dans la physiq c (SB: remplace le call conv_lipress_gcm(playgcm) ) c--------------------------------------------------------------------- do k = 1, klev play(k) = playgcm(k) print*,'la pression gcm est:',play(k) enddo c---------------------------------------------------------------------- c lecture du descripteur des donnees Meso-NH (forcing.ctl): c -> nb niveaux du meso.NH (nblvlm) + pressions meso.NH c (on remplit le COMMON physiq2) c---------------------------------------------------------------------- call mesolupbis(file_forctl) print*,'la valeur de nblvlm est:',nblvlm c---------------------------------------------------------------------- c etude de la correspondance entre les niveaux meso.NH et GCM; c calcul des coefficients d'interpolation coef1 et coef2 c (on remplit le COMMON physiq1) c---------------------------------------------------------------------- call corresbis(psolgcm) c--------------------------------------------------------- c TEST sur le remplissage de physiq1 et physiq2: c--------------------------------------------------------- write(*,*) ' ' write(*,*) 'TESTS physiq1 et physiq2 dans copie.F ' write(*,*) '--------------------------------------' write(*,*) 'GCM: nb niveaux:',klev,' et pression, coeffs:' do k = 1, klev write(*,*) play(k), coef1(k), coef2(k) enddo write(*,*) 'MESO-NH: nb niveaux:',nblvlm,' et pression:' do k = 1, nblvlm write(*,*) playm(k), hplaym(k) enddo write(*,*) ' ' end SUBROUTINE writeg1d(ngrid,nx,x,nom,titre) IMPLICIT NONE c....................................................................... c c ecriture de x pour GRADS-1D c c in : c * ngrid ---> pour controler que l'on est bien en 1D c * nx ---> taille du vecteur a stocker c "1" pour une variable de surface c "nlayer" pour une variable de centre de couche c "nlayer+1" pour une variable d'interface c * x ---> variable a stocker c * nom ---> nom "pour grads" c * titre ---> titre "pour grads" c c....................................................................... c #include "comg1d.h" c c....................................................................... c declaration des arguments c INTEGER ngrid,nx REAL x(nx) CHARACTER*(*) nom CHARACTER*(*) titre c c declaration des arguments c....................................................................... c declaration des variables locales c INTEGER ilayer,ivar LOGICAL test c c declaration des variables locales c....................................................................... c contole 1D c c print*,'ngrid=',ngrid IF (ngrid.NE.1) return c c contole 1D c....................................................................... c ouverture du fichier au premier appel c IF (g1d_premier) THEN OPEN (g1d_unitfich,FILE=g1d_nomfich & ,FORM='unformatted',ACCESS='direct',RECL=4) g1d_irec=0 g1d_nvar=0 g1d_premier=.false. ENDIF c c ouverture du fichier au premier appel c....................................................................... c pour l'ecriture du fichier ctl c test=.true. DO ivar=1,g1d_nvar IF (nom.EQ.g1d_nomvar(ivar)) test=.false. ENDDO IF (test) THEN g1d_nvar=g1d_nvar+1 g1d_nomvar(g1d_nvar)=nom g1d_titrevar(g1d_nvar)=titre IF (nx.EQ.1) THEN g1d_dimvar(g1d_nvar)=0 ELSEIF (nx.EQ.g1d_nlayer) THEN g1d_dimvar(g1d_nvar)=g1d_nlayer ELSEIF (nx.EQ.g1d_nlayer+1) THEN g1d_dimvar(g1d_nvar)=g1d_nlayer ELSE PRINT *,'._. probleme de dimension dans GRADS-1D ._.' ENDIF ENDIF c c pour l'ecriture du fichier ctl c....................................................................... c ecriture c IF (nx.EQ.1) THEN g1d_irec=g1d_irec+1 WRITE(g1d_unitfich,REC=g1d_irec) x(1) ELSE DO ilayer=1,g1d_nlayer g1d_irec=g1d_irec+1 WRITE(g1d_unitfich,REC=g1d_irec) x(ilayer) ENDDO ENDIF c c ecriture c....................................................................... c 10001 CONTINUE c c....................................................................... c RETURN END c SB SUBROUTINE endg1d(ngrid,nlayer,zlayer,ndt) SUBROUTINE endg1d(ngrid,nlayer,player,ndt,dt) IMPLICIT NONE c....................................................................... c c ecriture du fichier de controle pour GRADS-1D c c in : c * ngrid ---> pour controler que l'on est bien en 1D c * nlayer ---> nombre de couches c * zlayer ---> altitude au centre de chaque couche (km) c * player ---> pression au centre de chaque couche (hPa) c * ndt ---> nombre de pas de temps c * dt ---> valeur du pas de temps (s) c c....................................................................... c #include "comg1d.h" c c....................................................................... c declaration des arguments c INTEGER ngrid,nlayer c SB REAL zlayer(nlayer) REAL player(nlayer) INTEGER ndt REAL dt,dtm c c declaration des arguments c....................................................................... c declaration des variables locales c INTEGER ivar,ilayer c c declaration des variables locales c....................................................................... c contole 1D c IF (ngrid.NE.1) GOTO 10001 c c contole 1D c....................................................................... c IF (nlayer.ne.g1d_nlayer) & PRINT *,'._. probleme de dimension dans GRADS-1D ._.' c c....................................................................... c CLOSE (g1d_unitfich) c c....................................................................... c dtm = dt/60. OPEN (g1d_unitctl,FILE=g1d_nomctl,FORM='formatted' s ,status='new') WRITE (g1d_unitctl,'(a4,2x,a20)') 'DSET',g1d_nomfich WRITE (g1d_unitctl,'(a5,2x,a20)') 'UNDEF ','1.E+30' WRITE (g1d_unitctl,'(a11)') 'FORMAT YREV' WRITE (g1d_unitctl,'(a5,2x,a30)') 'TITLE ','champs 1D' WRITE (g1d_unitctl,'(a5,i4,a20)') 'XDEF ',1,' LINEAR 0 1' WRITE (g1d_unitctl,'(a5,i4,a20)') 'YDEF ',1,' LINEAR 0 1' WRITE (g1d_unitctl,'(a5,i4,a20)') 'ZDEF ',g1d_nlayer,' LEVELS' WRITE (g1d_unitctl,'(5(1x,f13.5))') c SB & (zlayer(ilayer),ilayer=1,g1d_nlayer) & (player(ilayer)/100.,ilayer=1,g1d_nlayer) c SB WRITE (g1d_unitctl,'(a4,2x,i10,a25)') c SB & 'TDEF ',ndt,' LINEAR 02JAN1987 1HR ' WRITE (g1d_unitctl,'(a4,2x,i10,a20,i3,a3)') & 'TDEF ',ndt,' LINEAR 02JAN1987 ',INT(dtm),'MN ' WRITE (g1d_unitctl,'(a5,i5)') 'VARS ',g1d_nvar DO ivar=1,g1d_nvar WRITE (g1d_unitctl,'(a5,3x,i4,i3,1x,a39)') & g1d_nomvar(ivar),g1d_dimvar(ivar),99,g1d_titrevar(ivar) ENDDO WRITE (g1d_unitctl,'(a7)') 'ENDVARS' CLOSE (g1d_unitctl) c c....................................................................... c 10001 CONTINUE c c....................................................................... c RETURN END SUBROUTINE mesolupbis(file_forctl) implicit none c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c Lecture descripteur des donnees MESO-NH (forcing.ctl): c ------------------------------------------------------- c c Cette subroutine lit dans le fichier de controle "essai.ctl" c et affiche le nombre de niveaux du Meso-NH ainsi que les valeurs c des pressions en milieu de couche du Meso-NH (en Pa puis en hPa). cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c INTEGER nblvlm !nombre de niveau de pression du mesoNH REAL playm(100) !pression en Pa milieu de chaque couche Meso-NH REAL hplaym(100) !pression en hPa des milieux de couche Meso-NH COMMON/physiq2/nblvlm,playm,hplaym INTEGER i,lu,k,mlz,mlzh,j character*80 file_forctl character*4 a character*80 aaa,anblvl,spaces integer nch lu=9 c open (lu,file='forcing.ctl') open(lu,file=file_forctl,form='formatted') c do i=1,1000 read(lu,1000,end=999) a if (a .eq. 'ZDEF') go to 100 enddo c 100 backspace(lu) print*,' DESCRIPTION DES 2 MODELES : ' print*,' ' c read(lu,2000) aaa 2000 format (a80) aaa=spaces(aaa,1) call getsch(aaa,' ',' ',2,anblvl,nch) read(anblvl,*) nblvlm c write(*,*) 'ATTENTION! dans mesolupbis on rentre c : nblvlm a la main car pas de bibliotheque CERN..:' c CASE_e: c! nblvlm = 43 c TOGA: c!! nblvlm = 40 c print*,'nbre de niveaux de pression Meso-NH :',nblvlm print*,' ' print*,'pression en Pa de chaque couche du meso-NH :' c read(lu,*) (playm(mlz),mlz=1,nblvlm) c Si la pression est en HPa, la multiplier par 100 if (playm(1) .lt. 10000.) then do mlz = 1,nblvlm playm(mlz) = playm(mlz)*100. enddo endif print*,(playm(mlz),mlz=1,nblvlm) c 1000 format (a4) 1001 format(5x,i2) c print*,' ' do mlzh=1,nblvlm hplaym(mlzh)=playm(mlzh)/100. enddo c print*,'pression en hPa de chaque couche du meso-NH: ' print*,(hplaym(mlzh),mlzh=1,nblvlm) c close (lu) return c 999 stop 'erreur lecture des niveaux pression des donnees' end SUBROUTINE GETSCH(STR,DEL,TRM,NTH,SST,NCH) C*************************************************************** C* * C* * C* GETSCH * C* * C* * C* modified by : * C*************************************************************** C* Return in SST the character string found between the NTH-1 and NTH C* occurence of the delimiter 'DEL' but before the terminator 'TRM' in C* the input string 'STR'. If TRM=DEL then STR is considered unlimited. C* NCH=Length of the string returned in SST or =-1 if NTH is <1 or if C* NTH is greater than the number of delimiters in STR. IMPLICIT INTEGER (A-Z) CHARACTER STR*(*),DEL*1,TRM*1,SST*(*) NCH=-1 SST=' ' IF(NTH.GT.0) THEN IF(TRM.EQ.DEL) THEN LENGTH=LEN(STR) ELSE LENGTH=INDEX(STR,TRM)-1 IF(LENGTH.LT.0) LENGTH=LEN(STR) ENDIF C* Find beginning and end of the NTH DEL-limited substring in STR END=-1 DO 1,N=1,NTH IF(END.EQ.LENGTH) RETURN BEG=END+2 END=BEG+INDEX(STR(BEG:LENGTH),DEL)-2 IF(END.EQ.BEG-2) END=LENGTH C* PRINT *,'NTH,LENGTH,N,BEG,END=',NTH,LENGTH,N,BEG,END 1 CONTINUE NCH=END-BEG+1 IF(NCH.GT.0) SST=STR(BEG:END) ENDIF END SUBROUTINE rdgrads(itape,icount,nl,z,ht,hq,hw) IMPLICIT none INTEGER itape,icount,icomp, nl real z(nl),ht(nl),hq(nl),hw(nl) c INTEGER i, k c icomp = icount c c do k=1,nl icomp=icomp+1 read(itape,rec=icomp)z(k) enddo do k=1,nl icomp=icomp+1 read(itape,rec=icomp)hT(k) enddo do k=1,nl icomp=icomp+1 read(itape,rec=icomp)hQ(k) enddo do k=1,nl icomp=icomp+1 read(itape,rec=icomp)hw(k) enddo c c RETURN END SUBROUTINE corresbis(psol) implicit none ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Cette subroutine calcule et affiche les valeurs des coefficients c d'interpolation qui serviront dans la formule d'interpolation elle- c meme. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc INTEGER klev !nombre de niveau de pression du GCM REAL play(100) !pression en Pa au milieu de chaque couche GCM INTEGER JM(100) REAL coef1(100) !coefficient d'interpolation REAL coef2(100) !coefficient d'interpolation INTEGER nblvlm !nombre de niveau de pression du mesoNH REAL playm(100) !pression en Pa milieu de chaque couche Meso-NH REAL hplaym(100)!pression en hPa des milieux de couche Meso-NH COMMON/physiq1/klev,play,JM,coef1,coef2 COMMON/physiq2/nblvlm,playm,hplaym REAL psol REAL val INTEGER k, mlz, mlzh do k=1,klev val=play(k) if (val .gt. playm(1)) then mlz = 0 JM(1) = mlz coef1(1)=(playm(mlz+1)-val) * /(playm(mlz+1)-psol) coef2(1)=(val-psol) * /(playm(mlz+1)-psol) else do mlz=1,nblvlm if ( val .le. playm(mlz) * .and. val .gt. playm(mlz+1))then JM(k)=mlz coef1(k)=(playm(mlz+1)-val) * /(playm(mlz+1)-playm(mlz)) coef2(k)=(val-playm(mlz)) * /(playm(mlz+1)-playm(mlz)) endif c enddo endif enddo c if (play(klev) .le. playm(nblvlm)) then mlz=nblvlm-1 JM(klev)=mlz coef1(klev)=(playm(mlz+1)-val) * /(playm(mlz+1)-playm(mlz)) coef2(klev)=(val-playm(mlz)) * /(playm(mlz+1)-playm(mlz)) endif c print*,' ' print*,' INTERPOLATION : ' print*,' ' print*,'correspondance de 9 niveaux du GCM sur les 53 du meso-NH:' print*,(JM(k),k=1,klev) print*,'correspondance de 9 niveaux du GCM sur les 53 du meso-NH:' print*,(JM(k),k=1,klev) print*,' ' print*,'valeurs du premier coef d"interpolation pour les 9 niveaux *: ' print*,(coef1(k),k=1,klev) print*,' ' print*,'valeurs du deuxieme coef d"interpolation pour les 9 niveau *x: ' print*,(coef2(k),k=1,klev) c return end SUBROUTINE phyredem (fichnom,dtime,radpas,co2_ppm,solaire, . rlat,rlon,tsol,tsoil,deltat,qsol,snow, . radsol,rugmer,agesno, . zmea,zstd,zsig,zgam,zthe,zpic,zval,rugsrel, . t_ancien, q_ancien) IMPLICIT none c====================================================================== c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 c Objet: Ecriture de l'etat de redemarrage pour la physique c====================================================================== #include "dimensions.h" #include "dimphy.h" #include "netcdf.inc" #include "indicesol.h" #include "dimsoil.h" #include "clesphys.h" #include "control.h" #include "temps.h" c====================================================================== CHARACTER*(*) fichnom REAL dtime INTEGER radpas REAL rlat(klon), rlon(klon) REAL co2_ppm REAL solaire REAL tsol(klon,nbsrf) REAL tsoil(klon,nsoilmx,nbsrf) REAL deltat(klon) REAL qsol(klon,nbsrf) REAL snow(klon,nbsrf) REAL radsol(klon) REAL rugmer(klon) REAL agesno(klon) REAL zmea(klon) REAL zstd(klon) REAL zsig(klon) REAL zgam(klon) REAL zthe(klon) REAL zpic(klon) REAL zval(klon) REAL rugsrel(klon) REAL t_ancien(klon,klev), q_ancien(klon,klev) c INTEGER nid, nvarid, idim1, idim2, idim3 INTEGER ierr INTEGER length PARAMETER (length=100) REAL tab_cntrl(length) c INTEGER isoil, nsrf CHARACTER*7 str7 CHARACTER*2 str2 c ierr = NF_CREATE(fichnom, NF_CLOBBER, nid) IF (ierr.NE.NF_NOERR) THEN write(6,*)' Pb d''ouverture du fichier '//fichnom write(6,*)' ierr = ', ierr CALL ABORT ENDIF c ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 28, . "Fichier redemmarage physique") c ierr = NF_DEF_DIM (nid, "index", length, idim1) ierr = NF_DEF_DIM (nid, "points_physiques", klon, idim2) ierr = NF_DEF_DIM (nid, "horizon_vertical", klon*klev, idim3) c ierr = NF_ENDDEF(nid) c DO ierr = 1, length tab_cntrl(ierr) = 0.0 ENDDO tab_cntrl(1) = dtime tab_cntrl(2) = radpas tab_cntrl(3) = co2_ppm tab_cntrl(4) = solaire tab_cntrl(5) = iflag_con tab_cntrl(6) = nbapp_rad IF( cycle_diurne ) tab_cntrl( 7 ) = 1. IF( soil_model ) tab_cntrl( 8 ) = 1. IF( new_oliq ) tab_cntrl( 9 ) = 1. IF( ok_orodr ) tab_cntrl(10 ) = 1. IF( ok_orolf ) tab_cntrl(11 ) = 1. tab_cntrl(13) = dayref tab_cntrl(14) = anneeref tab_cntrl(13) = day_end tab_cntrl(14) = anne_ini c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, idim1,nvarid) #else ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, idim1,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22, . "Parametres de controle") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "longitude", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "longitude", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32, . "Longitudes de la grille physique") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlon) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,rlon) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "latitude", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 31, . "Latitudes de la grille physique") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlat) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,rlat) #endif c c DO nsrf = 1, nbsrf IF (nsrf.LE.99) THEN WRITE(str2,'(i2.2)') nsrf ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "TS"//str2, NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "TS"//str2, NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, . "Temperature de surface No."//str2) ierr = NF_ENDDEF(nid) ELSE PRINT*, "Trop de sous-mailles" CALL abort ENDIF #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsol(1,nsrf)) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,tsol(1,nsrf)) #endif ENDDO c DO nsrf = 1, nbsrf DO isoil=1, nsoilmx IF (isoil.LE.99 .AND. nsrf.LE.99) THEN WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_DOUBLE,1,idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "Tsoil"//str7,NF_FLOAT,1,idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 29, . "Temperature du sol No."//str7) ierr = NF_ENDDEF(nid) ELSE PRINT*, "Trop de couches" CALL abort ENDIF #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsoil(1,isoil,nsrf)) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,tsoil(1,isoil,nsrf)) #endif ENDDO ENDDO c c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "DELTAT", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "DELTAT", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33, . "Ecart de la SST (pour slab-ocean)") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,deltat) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,deltat) #endif c DO nsrf = 1, nbsrf IF (nsrf.LE.99) THEN WRITE(str2,'(i2.2)') nsrf ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid,"QS"//str2,NF_DOUBLE,1,idim2,nvarid) #else ierr = NF_DEF_VAR (nid,"QS"//str2,NF_FLOAT,1,idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 25, . "Humidite de surface No."//str2) ierr = NF_ENDDEF(nid) ELSE PRINT*, "Trop de sous-mailles" CALL abort ENDIF #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,qsol(1,nsrf)) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,qsol(1,nsrf)) #endif ENDDO c DO nsrf = 1, nbsrf IF (nsrf.LE.99) THEN WRITE(str2,'(i2.2)') nsrf ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_DOUBLE,1,idim2,nvarid) #else ierr = NF_DEF_VAR (nid,"SNOW"//str2,NF_FLOAT,1,idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22, . "Neige de surface No."//str2) ierr = NF_ENDDEF(nid) ELSE PRINT*, "Trop de sous-mailles" CALL abort ENDIF #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,snow(1,nsrf)) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,snow(1,nsrf)) #endif ENDDO c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "RADS", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "RADS", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, . "Rayonnement net a la surface") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,radsol) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,radsol) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "RUGMER", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "RUGMER", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, . "Longueur de rugosite sur mer") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugmer) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,rugmer) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "AGESNO", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "AGESNO", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15, . "Age de la neige") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,agesno) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,agesno) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZMEA", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zmea) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,zmea) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZSTD", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZSTD", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zstd) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,zstd) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZSIG", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZSIG", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zsig) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,zsig) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZGAM", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZGAM", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zgam) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,zgam) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZTHE", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZTHE", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zthe) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,zthe) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZPIC", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZPIC", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zpic) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,zpic) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZVAL", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZVAL", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,zval) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,zval) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "RUGSREL", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "RUGSREL", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugsrel) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,rugsrel) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "TANCIEN", NF_DOUBLE, 1, idim3,nvarid) #else ierr = NF_DEF_VAR (nid, "TANCIEN", NF_FLOAT, 1, idim3,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,t_ancien) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,t_ancien) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "QANCIEN", NF_DOUBLE, 1, idim3,nvarid) #else ierr = NF_DEF_VAR (nid, "QANCIEN", NF_FLOAT, 1, idim3,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q_ancien) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,q_ancien) #endif c ierr = NF_CLOSE(nid) c RETURN END subroutine physdem(lonfi, latfi,phystep,radpas,co2_ppm, . solaire, ts, ws, . sn, radsol, deltat, rugmer, . agesno, zmea, zstd, zsig, . zgam, zthe, zpic, zval, . rugsrel) IMPLICIT none c------------------------------------------------------------- C Author : L. Fairhead C Date : 01/10/1999 C Objet : Ecriture des etats initiaux physiques c------------------------------------------------------------- c c c INTEGER ivap PARAMETER (ivap=1) c REAL qsolmax PARAMETER ( qsolmax = 150.0 ) c #include "dimensions.h" #include "paramet.h" #include "dimphy.h" #include "control.h" #include "netcdf.inc" c INTEGER nid c Ajout de quelques parametres orographiques (F. LOTT janvier 1995) REAL zmea(iip1,jjp1),zstd(iip1,jjp1) REAL zsig(iip1,jjp1),zgam(iip1,jjp1),zthe(iip1,jjp1) REAL zpic(iip1,jjp1),zval(iip1,jjp1) REAL rugsrel(iip1,jjp1) INTEGER idayref,anneeref integer ierr, idim1, idim2, nvarid c REAL phystep INTEGER radpas REAL co2_ppm REAL solaire REAL latfi(klon), lonfi(klon) REAL champhys(klon) REAL ts(klon) REAL deltat(klon) REAL ws(klon) REAL sn(klon) REAL radsol(klon) REAL rugmer(klon) REAL agesno(klon) INTEGER length PARAMETER (length=100) REAL tab_cntrl(length) real pi c #include "serre.h" #include "clesphys.h" #include "fxyprim.h" c----------------------------------------------------------------------- c c stockage sur le fichier Physique: c pi=2.*asin(1.) ierr = NF_CREATE("startphy.nc", NF_CLOBBER, nid) IF (ierr.NE.NF_NOERR) THEN WRITE(6,*)' Pb d''ouverture du fichier startphy.nc' WRITE(6,*)' ierr = ', ierr CALL ABORT ENDIF c ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 28, . "Fichier demmarage physique") c ierr = NF_DEF_DIM (nid, "index", length, idim1) ierr = NF_DEF_DIM (nid, "points_physiques", klon, idim2) c ierr = NF_ENDDEF(nid) c DO ierr = 1, length tab_cntrl(ierr) = 0.0 ENDDO tab_cntrl(1) = phystep tab_cntrl(2) = radpas tab_cntrl(3) = co2_ppm tab_cntrl(4) = solaire tab_cntrl(5) = iflag_con tab_cntrl(6) = nbapp_rad c cc Modif ( P. Le Van ) c tab_cntrl( 7 ) = 0. tab_cntrl( 8 ) = 0. tab_cntrl( 9 ) = 0. tab_cntrl(10 ) = 0. tab_cntrl(11 ) = 0. tab_cntrl(12 ) = 0. IF( cycle_diurne ) tab_cntrl( 7 ) = 1. IF( soil_model ) tab_cntrl( 8 ) = 1. IF( new_oliq ) tab_cntrl( 9 ) = 1. IF( ok_orodr ) tab_cntrl(10 ) = 1. IF( ok_orolf ) tab_cntrl(11 ) = 1. IF( ok_limitvrai ) tab_cntrl(12 ) = 1. tab_cntrl(13) = dayref tab_cntrl(14) = anneeref cc *** new_oliq ( commentaires de L. LI dans routine physique ) cc *** ok_orodr et ok_orolf si on appelle l'orographie **** c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "controle", NF_DOUBLE, 1, idim1,nvarid) #else ierr = NF_DEF_VAR (nid, "controle", NF_FLOAT, 1, idim1,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 22, . "Parametres de controle") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "longitude", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "longitude", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32, . "Longitudes de la grille physique") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,lonfi) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,lonfi) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "latitude", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "latitude", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 31, . "Latitudes de la grille physique") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,latfi) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,latfi) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "TS", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "TS", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 25, . "Temperature de la surface") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ts) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,ts) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "QS", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "QS", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, . "Humidite du sol") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ws) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,ws) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "SNOW", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "SNOW", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 5, . "Neige") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sn) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,sn) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "RADS", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "RADS", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, . "Rayonnement net a la surface") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,radsol) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,radsol) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "DELTAT", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "DELTAT", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 33, . "Ecart de la SST (pour slab-ocean)") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,deltat) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,deltat) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "RUGMER", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "RUGMER", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, . "Longueur de rugosite sur mer") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rugmer) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,rugmer) #endif c ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "AGESNO", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "AGESNO", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 15, . "Age de la neige") ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,agesno) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,agesno) #endif c CALL gr_dyn_fi(1, iip1, jjp1, klon, zmea, champhys) ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZMEA", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys) #endif c CALL gr_dyn_fi(1, iip1, jjp1, klon, zstd, champhys) ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZSTD", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZSTD", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys) #endif CALL gr_dyn_fi(1, iip1, jjp1, klon, zsig, champhys) ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZSIG", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZSIG", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys) #endif CALL gr_dyn_fi(1, iip1, jjp1, klon, zgam, champhys) ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZGAM", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZGAM", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys) #endif CALL gr_dyn_fi(1, iip1, jjp1, klon, zthe, champhys) ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZTHE", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZTHE", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys) #endif CALL gr_dyn_fi(1, iip1, jjp1, klon, zpic, champhys) ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZPIC", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZPIC", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys) #endif CALL gr_dyn_fi(1, iip1, jjp1, klon, zval, champhys) ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "ZVAL", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "ZVAL", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys) #endif CALL gr_dyn_fi(1, iip1, jjp1, klon, rugsrel, champhys) ierr = NF_REDEF (nid) #ifdef NC_DOUBLE ierr = NF_DEF_VAR (nid, "RUGSREL", NF_DOUBLE, 1, idim2,nvarid) #else ierr = NF_DEF_VAR (nid, "RUGSREL", NF_FLOAT, 1, idim2,nvarid) #endif ierr = NF_ENDDEF(nid) #ifdef NC_DOUBLE ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,champhys) #else ierr = NF_PUT_VAR_REAL (nid,nvarid,champhys) #endif c ierr = NF_CLOSE(nid) RETURN END *CMZ : 28/02/95 17.58.56 by Unknown *-- Author : CHARACTER*(*) FUNCTION SPACES(STR,NSPACE) C C CERN PROGLIB# M433 SPACES .VERSION KERNFOR 4.14 860211 C ORIG. 6/05/86 M.GOOSSENS/DD C C- The function value SPACES returns the character string STR with C- leading blanks removed and each occurence of one or more blanks C- replaced by NSPACE blanks inside the string STR C CHARACTER*(*) STR C LENSPA = LEN(SPACES) SPACES = ' ' IF (NSPACE.LT.0) NSPACE = 0 IBLANK = 1 ISPACE = 1 100 INONBL = INDEXC(STR(IBLANK:),' ') IF (INONBL.EQ.0) THEN SPACES(ISPACE:) = STR(IBLANK:) GO TO 999 ENDIF INONBL = INONBL + IBLANK - 1 IBLANK = INDEX(STR(INONBL:),' ') IF (IBLANK.EQ.0) THEN SPACES(ISPACE:) = STR(INONBL:) GO TO 999 ENDIF IBLANK = IBLANK + INONBL - 1 SPACES(ISPACE:) = STR(INONBL:IBLANK-1) ISPACE = ISPACE + IBLANK - INONBL + NSPACE IF (ISPACE.LE.LENSPA) GO TO 100 999 END FUNCTION INDEXC(STR,SSTR) C C CERN PROGLIB# M433 INDEXC .VERSION KERNFOR 4.14 860211 C ORIG. 26/03/86 M.GOOSSENS/DD C C- Find the leftmost position where substring SSTR does not match C- string STR scanning forward C CHARACTER*(*) STR,SSTR C LENS = LEN(STR) LENSS = LEN(SSTR) C DO 10 I=1,LENS-LENSS+1 IF (STR(I:I+LENSS-1).NE.SSTR) THEN INDEXC = I GO TO 999 ENDIF 10 CONTINUE INDEXC = 0 C 999 END