Index: /trunk/DOC/chantiers/commit_importants.log =================================================================== --- /trunk/DOC/chantiers/commit_importants.log (revision 1539) +++ /trunk/DOC/chantiers/commit_importants.log (revision 1540) @@ -1672,2 +1672,15 @@ Only partially done for Titan, because of many hard-coded commons; a necessary first step will be to clean these up (using modules). + +********************** +**** commit_v1540 **** +********************** +Ehouarn: Further adaptations to keep up with changes in LMDZ5 concerning +physics/dynamics separation: +- changed directory "dynlonlat_phylonlat" to "dynphy_lonlat" and adapted + makelmdz and makelmdz_fcm scripts accordingly. +- added option "-libphy" to makelmdz_fcm to just build a physics library, + without any main program (not operational yet; further cleanup in the + physics required). +- moved "iniprint.h" from dyn3d_common to misc (NB: it is used in both physics + and dynamics; this should be cleaned up further...) Index: /trunk/LMDZ.COMMON/bld.cfg =================================================================== --- /trunk/LMDZ.COMMON/bld.cfg (revision 1539) +++ /trunk/LMDZ.COMMON/bld.cfg (revision 1540) @@ -42,12 +42,11 @@ -bld::outfile_ext::exe %SUFF_NAME.e -bld::target liblmdz.a -bld::target %EXEC%SUFF_NAME.e +bld::outfile_ext::exe %SUFF_NAME +bld::target liblmdz.a %EXEC%SUFF_NAME bld::exe_dep dir::root %CONFIG_PATH -dir::lib %BASE_CONFIG_PATH +#dir::lib %BASE_CONFIG_PATH dir::bin %ROOT_PATH/bin Index: unk/LMDZ.COMMON/libf/dyn3d_common/iniprint.h =================================================================== --- /trunk/LMDZ.COMMON/libf/dyn3d_common/iniprint.h (revision 1539) +++ (revision ) @@ -1,11 +1,0 @@ -! -! $Header$ -! -! -! gestion des impressions de sorties et de débogage -! lunout: unité du fichier dans lequel se font les sorties -! (par defaut 6, la sortie standard) -! prt_level: niveau d'impression souhaité (0 = minimum) -! - INTEGER lunout, prt_level - COMMON /comprint/ lunout, prt_level Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/calfis.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/calfis.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/calfis.F (revision 1540) @@ -0,0 +1,958 @@ +! +! $Id: calfis.F 1407 2010-07-07 10:31:52Z fairhead $ +! +C +C + SUBROUTINE calfis(lafin, + $ jD_cur, jH_cur, + $ pucov, + $ pvcov, + $ pteta, + $ pq, + $ pmasse, + $ pps, + $ pp, + $ ppk, + $ pphis, + $ pphi, + $ pducov, + $ pdvcov, + $ pdteta, + $ pdq, + $ flxw, + $ pdufi, + $ pdvfi, + $ pdhfi, + $ pdqfi, + $ pdpsfi) +c +c Auteur : P. Le Van, F. Hourdin +c ......... + USE infotrac, ONLY: nqtot, niadv, tname + USE control_mod, ONLY: planet_type, nsplit_phys + USE write_field + USE cpdet_mod, only: t2tpot,tpot2t + +! used only for zonal averages + USE moyzon_mod + USE comvert_mod, ONLY: presnivs,preff + USE comconst_mod, ONLY: daysec,dtvr,dtphys,kappa,cpp,g,rad,pi + USE logic_mod, ONLY: moyzon_ch,moyzon_mu + + IMPLICIT NONE +c======================================================================= +c +c 1. rearrangement des tableaux et transformation +c variables dynamiques > variables physiques +c 2. calcul des termes physiques +c 3. retransformation des tendances physiques en tendances dynamiques +c +c remarques: +c ---------- +c +c - les vents sont donnes dans la physique par leurs composantes +c naturelles. +c - la variable thermodynamique de la physique est une variable +c intensive : T +c pour la dynamique on prend T * ( preff / p(l) ) **kappa +c - les deux seules variables dependant de la geometrie necessaires +c pour la physique sont la latitude pour le rayonnement et +c l'aire de la maille quand on veut integrer une grandeur +c horizontalement. +c - les points de la physique sont les points scalaires de la +c la dynamique; numerotation: +c 1 pour le pole nord +c (jjm-1)*iim pour l'interieur du domaine +c ngridmx pour le pole sud +c ---> ngridmx=2+(jjm-1)*iim +c +c Input : +c ------- +c pucov covariant zonal velocity +c pvcov covariant meridional velocity +c pteta potential temperature +c pps surface pressure +c pmasse masse d'air dans chaque maille +c pts surface temperature (K) +c callrad clef d'appel au rayonnement +c +c Output : +c -------- +c pdufi tendency for the natural zonal velocity (ms-1) +c pdvfi tendency for the natural meridional velocity +c pdhfi tendency for the potential temperature (K/s) +c pdtsfi tendency for the surface temperature +c +c pdtrad radiative tendencies \ both input +c pfluxrad radiative fluxes / and output +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ + + include "dimensions.h" + include "paramet.h" + + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + + include "comgeom2.h" + include "iniprint.h" + +c Arguments : +c ----------- + LOGICAL,INTENT(IN) :: lafin ! .true. for the very last call to physics + REAL,INTENT(IN) :: jD_cur, jH_cur + REAL,INTENT(IN) :: pvcov(iip1,jjm,llm) ! covariant meridional velocity + REAL,INTENT(IN) :: pucov(iip1,jjp1,llm) ! covariant zonal velocity + REAL,INTENT(IN) :: pteta(iip1,jjp1,llm) ! potential temperature + REAL,INTENT(IN) :: pmasse(iip1,jjp1,llm) ! mass in each cell ! not used + REAL,INTENT(IN) :: pq(iip1,jjp1,llm,nqtot) ! tracers + REAL,INTENT(IN) :: pphis(iip1,jjp1) ! surface geopotential + REAL,INTENT(IN) :: pphi(iip1,jjp1,llm) ! geopotential + + REAL,INTENT(IN) :: pdvcov(iip1,jjm,llm) ! dynamical tendency on vcov + REAL,INTENT(IN) :: pducov(iip1,jjp1,llm) ! dynamical tendency on ucov + REAL,INTENT(IN) :: pdteta(iip1,jjp1,llm) ! dynamical tendency on teta +! commentaire SL: pdq ne sert que pour le calcul de pcvgq, +! qui lui meme ne sert a rien dans la routine telle qu'elle est +! ecrite, et que j'ai donc commente.... + REAL,INTENT(IN) :: pdq(iip1,jjp1,llm,nqtot) ! dynamical tendency on tracers + ! NB: pdq is only used to compute pcvgq which is in fact not used... + + REAL,INTENT(IN) :: pps(iip1,jjp1) ! surface pressure (Pa) + REAL,INTENT(IN) :: pp(iip1,jjp1,llmp1) ! pressure at mesh interfaces (Pa) + REAL,INTENT(IN) :: ppk(iip1,jjp1,llm) ! Exner at mid-layer + REAL,INTENT(IN) :: flxw(iip1,jjp1,llm) ! Vertical mass flux on lower mesh interfaces (kg/s) (on llm because flxw(:,:,llm+1)=0) + + ! tendencies (in */s) from the physics + REAL,INTENT(OUT) :: pdvfi(iip1,jjm,llm) ! tendency on covariant meridional wind + REAL,INTENT(OUT) :: pdufi(iip1,jjp1,llm) ! tendency on covariant zonal wind + REAL,INTENT(OUT) :: pdhfi(iip1,jjp1,llm) ! tendency on potential temperature (K/s) + REAL,INTENT(OUT) :: pdqfi(iip1,jjp1,llm,nqtot) ! tendency on tracers + REAL,INTENT(OUT) :: pdpsfi(iip1,jjp1) ! tendency on surface pressure (Pa/s) + +#ifndef CPP_PARA +c Local variables : +c ----------------- + + INTEGER i,j,l,ig0,ig,iq,iiq + REAL zpsrf(ngridmx) + REAL zplev(ngridmx,llm+1),zplay(ngridmx,llm) + REAL zphi(ngridmx,llm),zphis(ngridmx) + + REAL zufi(ngridmx,llm), zvfi(ngridmx,llm) + REAL ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot) +! ADAPTATION GCM POUR CP(T) + REAL zteta(ngridmx,llm) + REAL zpk(ngridmx,llm) + +! RQ SL 13/10/10: +! Ces calculs ne servent pas. +! Si necessaire, decommenter ces variables et les calculs... +! REAL pcvgu(ngridmx,llm), pcvgv(ngridmx,llm) +! REAL pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2) + + REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm) + REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot) + REAL zdpsrf(ngridmx) + + REAL zdufic(ngridmx,llm),zdvfic(ngridmx,llm) + REAL zdtfic(ngridmx,llm),zdqfic(ngridmx,llm,nqtot) + REAL jH_cur_split,zdt_split + LOGICAL debut_split,lafin_split + INTEGER isplit + + REAL zsin(iim),zcos(iim),z1(iim) + REAL zsinbis(iim),zcosbis(iim),z1bis(iim) + REAL unskap, pksurcp + save unskap + + REAL flxwfi(ngridmx,llm) ! Flux de masse verticale sur la grille physiq + + REAL SSUM + + LOGICAL,SAVE :: firstcal=.true., debut=.true. +! REAL rdayvrai + + LOGICAL tracerdyn ! for generic/mars physics call ; possibly to get rid of + +! For Titan only right now: +! to allow for 2D computation of microphys and chemistry + LOGICAL,save :: flag_moyzon + REAL,allocatable,save :: tmpvar(:,:) + REAL,allocatable,save :: tmpvarp1(:,:) + REAL,allocatable,save :: tmpvarbar(:) + REAL,allocatable,save :: tmpvarbarp1(:) + real :: zz1,zz2 + +c----------------------------------------------------------------------- + +c 1. Initialisations : +c -------------------- + + + IF ( firstcal ) THEN + debut = .TRUE. + IF (ngridmx.NE.2+(jjm-1)*iim) THEN + write(lunout,*) 'STOP dans calfis' + write(lunout,*) + & 'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim' + write(lunout,*) ' ngridmx jjm iim ' + write(lunout,*) ngridmx,jjm,iim + STOP + ENDIF + + unskap = 1./ kappa + + flag_moyzon = .false. + if(moyzon_ch.or.moyzon_mu) then + flag_moyzon = .true. + allocate(tmpvar(iip1,llm)) + allocate(tmpvarp1(iip1,llmp1)) + allocate(tmpvarbar(llm)) + allocate(tmpvarbarp1(llmp1)) + endif + + if (flag_moyzon) call moyzon_init(ngridmx,llm,nqtot) + +c---------------------------------------------- +c moyennes globales pour le profil de pression + if(planet_type.eq."titan".or.planet_type.eq."venus") then + ALLOCATE(plevmoy(llm+1)) + ALLOCATE(playmoy(llm)) + ALLOCATE(tmoy(llm)) + ALLOCATE(tetamoy(llm)) + ALLOCATE(pkmoy(llm)) + ALLOCATE(phimoy(0:llm)) + ALLOCATE(zlevmoy(llm+1)) + ALLOCATE(zlaymoy(llm)) + plevmoy=0. + do l=1,llmp1 + do i=1,iip1 + do j=1,jjp1 + plevmoy(l)=plevmoy(l)+pp(i,j,l)/(iip1*jjp1) + enddo + enddo + enddo + tetamoy=0. + pkmoy=0. + phimoy=0. + do i=1,iip1 + do j=1,jjp1 + phimoy(0)=phimoy(0)+pphis(i,j)/(iip1*jjp1) + enddo + enddo + do l=1,llm + do i=1,iip1 + do j=1,jjp1 + tetamoy(l)=tetamoy(l)+pteta(i,j,l)/(iip1*jjp1) + pkmoy(l)=pkmoy(l)+ppk(i,j,l)/(iip1*jjp1) + phimoy(l)=phimoy(l)+pphi(i,j,l)/(iip1*jjp1) + enddo + enddo + enddo + playmoy(:) = preff * (pkmoy(:)/cpp) ** unskap + call tpot2t(llm,tetamoy,tmoy,pkmoy) +c SI ON TIENT COMPTE DE LA VARIATION DE G AVEC L'ALTITUDE: + zlaymoy(1:llm) = g*rad*rad/(g*rad-phimoy(1:llm))-rad + zlevmoy(1) = phimoy(0)/g + DO l=2,llm + zz1=(playmoy(l-1)+plevmoy(l))/(playmoy(l-1)-plevmoy(l)) + zz2=(plevmoy(l) +playmoy(l))/(plevmoy(l) -playmoy(l)) + zlevmoy(l)=(zz1*zlaymoy(l-1)+zz2*zlaymoy(l))/(zz1+zz2) + ENDDO + zlevmoy(llmp1)=zlaymoy(llm)+(zlaymoy(llm)-zlevmoy(llm)) +c------------------- +c + lat index + allocate(klat(ngridmx)) + klat=0 + klat(1) = 1 + ig0 = 2 + DO j = 2,jjm + do i=0,iim-1 + klat(ig0+i) = j + enddo + ig0 = ig0+iim + ENDDO + klat(ngridmx) = jjp1 + endif ! planet_type=titan +c---------------------------------------------- + ELSE + debut = .FALSE. + ENDIF ! of IF (firstcal) + + +c----------------------------------------------------------------------- +c 40. transformation des variables dynamiques en variables physiques: +c --------------------------------------------------------------- + +c 41. pressions au sol (en Pascals) +c ---------------------------------- + + zpsrf(1) = pps(1,1) + + ig0 = 2 + DO j = 2,jjm + CALL SCOPY( iim,pps(1,j),1,zpsrf(ig0), 1 ) + ig0 = ig0+iim + ENDDO + + zpsrf(ngridmx) = pps(1,jjp1) + +c 42. pression intercouches et fonction d'Exner: + +c ----------------------------------------------------------------- +c .... zplev definis aux (llm +1) interfaces des couches .... +c .... zplay definis aux ( llm ) milieux des couches .... +c ----------------------------------------------------------------- + +c ... Exner = cp * ( p(l) / preff ) ** kappa .... + +! ADAPTATION GCM POUR CP(T) + DO l = 1, llm + zpk( 1,l ) = ppk(1,1,l) + zteta( 1,l ) = pteta(1,1,l) + zplev( 1,l ) = pp(1,1,l) + ig0 = 2 + DO j = 2, jjm + DO i =1, iim + zpk( ig0,l ) = ppk(i,j,l) + zteta( ig0,l ) = pteta(i,j,l) + zplev( ig0,l ) = pp(i,j,l) + ig0 = ig0 +1 + ENDDO + ENDDO + zpk( ngridmx,l ) = ppk(1,jjp1,l) + zteta( ngridmx,l ) = pteta(1,jjp1,l) + zplev( ngridmx,l ) = pp(1,jjp1,l) + ENDDO + zplev( 1,llmp1 ) = pp(1,1,llmp1) + ig0 = 2 + DO j = 2, jjm + DO i =1, iim + zplev( ig0,llmp1 ) = pp(i,j,llmp1) + ig0 = ig0 +1 + ENDDO + ENDDO + zplev( ngridmx,llmp1 ) = pp(1,jjp1,llmp1) + + if (flag_moyzon) then + tmpvarp1(:,:) = pp(:,1,:) + call moyzon(llmp1,tmpvarp1,tmpvarbarp1) + zplevbar(1,:) = tmpvarbarp1 + tmpvar(:,:) = ppk(:,1,:) + call moyzon(llm,tmpvar,tmpvarbar) + zpkbar(1,:) = tmpvarbar + tmpvar(:,:) = pteta(:,1,:) + call moyzon(llm,tmpvar,tmpvarbar) + ztetabar(1,:) = tmpvarbar + call tpot2t(llm,ztetabar(1,:),ztfibar(1,:),zpkbar(1,:)) + ig0 = 2 + do j = 2, jjm + tmpvarp1(:,:) = pp(:,j,:) + call moyzon(llmp1,tmpvarp1,tmpvarbarp1) + zplevbar(ig0,:) = tmpvarbarp1 + tmpvar(:,:) = ppk(:,j,:) + call moyzon(llm,tmpvar,tmpvarbar) + zpkbar(ig0,:) = tmpvarbar + tmpvar(:,:) = pteta(:,j,:) + call moyzon(llm,tmpvar,tmpvarbar) + ztetabar(ig0,:) = tmpvarbar + call tpot2t(llm,ztetabar(ig0,:),ztfibar(ig0,:),zpkbar(ig0,:)) + ig0 = ig0+1 + do i=2,iim + zplevbar(ig0,:) = zplevbar(ig0-1,:) + zpkbar(ig0,:) = zpkbar(ig0-1,:) + ztetabar(ig0,:) = ztetabar(ig0-1,:) + ztfibar(ig0,:) = ztfibar(ig0-1,:) + ig0 = ig0+1 + enddo + enddo + tmpvarp1(:,:) = pp(:,jjp1,:) + call moyzon(llmp1,tmpvarp1,tmpvarbarp1) + zplevbar(ngridmx,:) = tmpvarbarp1 + tmpvar(:,:) = ppk(:,jjp1,:) + call moyzon(llm,tmpvar,tmpvarbar) + zpkbar(ngridmx,:) = tmpvarbar + tmpvar(:,:) = pteta(:,jjp1,:) + call moyzon(llm,tmpvar,tmpvarbar) + ztetabar(ngridmx,:) = tmpvarbar + call tpot2t(llm,ztetabar(ngridmx,:), + . ztfibar(ngridmx,:),zpkbar(ngridmx,:)) + endif + +c 43. temperature naturelle (en K) et pressions milieux couches . +c --------------------------------------------------------------- + +! ADAPTATION GCM POUR CP(T) + call tpot2t(ngridmx*llm,zteta,ztfi,zpk) + + DO l=1,llm + + pksurcp = ppk(1,1,l) / cpp + zplay(1,l) = preff * pksurcp ** unskap +! pcvgt(1,l) = pdteta(1,1,l) * pksurcp / pmasse(1,1,l) + ig0 = 2 + + DO j = 2, jjm + DO i = 1, iim + pksurcp = ppk(i,j,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap +! pcvgt(ig0,l) = pdteta(i,j,l) * pksurcp / pmasse(i,j,l) + ig0 = ig0 + 1 + ENDDO + ENDDO + + pksurcp = ppk(1,jjp1,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap +! pcvgt(ig0,l) = pdteta(1,jjp1,l) * pksurcp/ pmasse(1,jjp1,l) + + ENDDO + + if (flag_moyzon) then + zplaybar(:,:) = preff * (zpkbar(:,:)/cpp)**unskap + endif + +c 43.bis traceurs (tous intensifs) +c --------------- + + DO iq=1,nqtot + DO l=1,llm + zqfi(1,l,iq) = pq(1,1,l,iq) + ig0 = 2 + DO j=2,jjm + DO i = 1, iim + zqfi(ig0,l,iq) = pq(i,j,l,iq) + ig0 = ig0 + 1 + ENDDO + ENDDO + zqfi(ig0,l,iq) = pq(1,jjp1,l,iq) + ENDDO + ENDDO ! boucle sur traceurs + + if (flag_moyzon) then + DO iq=1,nqtot +! RQ: REVOIR A QUOI CA SERT... ET VERIFIER... +! iiq=niadv(iq) +! en fait, iiq=iq... +! FIN RQ + tmpvar(:,:) = pq(:,1,:,iq) + call moyzon(llm,tmpvar,tmpvarbar) + zqfibar(1,:,iq) = tmpvarbar + ig0 = 2 + do j = 2, jjm + tmpvar(:,:) = pq(:,j,:,iq) + call moyzon(llm,tmpvar,tmpvarbar) + zqfibar(ig0,:,iq) = tmpvarbar + ig0 = ig0+1 + do i=2,iim + zqfibar(ig0,:,iq) = zqfibar(ig0-1,:,iq) + ig0 = ig0+1 + enddo + enddo + tmpvar(:,:) = pq(:,jjp1,:,iq) + call moyzon(llm,tmpvar,tmpvarbar) + zqfibar(ngridmx,:,iq) = tmpvarbar + ENDDO ! of DO iq=1,nqtot + endif + +! DEBUG +! do ig0=1,ngridmx +! write(*,'(6(e13.5,1x))') zqfibar(ig0,1,10),zqfi(ig0,1,10), +! . zqfibar(ig0,llm/2,10),zqfi(ig0,llm/2,10), +! . zqfibar(ig0,llm,10),zqfi(ig0,llm,10) +! enddo +! stop + +!----------------- +! RQ SL 13/10/10: +! Ces calculs ne servent pas. +! Si necessaire, decommenter ces variables et les calculs... +! +! convergence dynamique pour les traceurs "EAU" +! Earth-specific treatment of first 2 tracers (water) +! if (planet_type=="earth") then +! DO iq=1,2 +! DO l=1,llm +! pcvgq(1,l,iq)= pdq(1,1,l,iq) / pmasse(1,1,l) +! ig0 = 2 +! DO j=2,jjm +! DO i = 1, iim +! pcvgq(ig0,l,iq) = pdq(i,j,l,iq) / pmasse(i,j,l) +! ig0 = ig0 + 1 +! ENDDO +! ENDDO +! pcvgq(ig0,l,iq)= pdq(1,jjp1,l,iq) / pmasse(1,jjp1,l) +! ENDDO +! ENDDO +! endif ! of if (planet_type=="earth") +!---------------- + +c Geopotentiel calcule par rapport a la surface locale: +c ----------------------------------------------------- + + CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi) + CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis) + DO l=1,llm + DO ig=1,ngridmx + zphi(ig,l)=zphi(ig,l)-zphis(ig) + ENDDO + ENDDO + + if (flag_moyzon) then + tmpvar(:,1) = pphis(:,1) + call moyzon(1,tmpvar(:,1),tmpvarbar(1)) + zphisbar(1) = tmpvarbar(1) + tmpvar(:,:) = pphi(:,1,:) + call moyzon(llm,tmpvar,tmpvarbar) + zphibar(1,:) = tmpvarbar + ig0 = 2 + do j = 2, jjm + tmpvar(:,1) = pphis(:,j) + call moyzon(1,tmpvar(:,1),tmpvarbar(1)) + zphisbar(ig0) = tmpvarbar(1) + tmpvar(:,:) = pphi(:,j,:) + call moyzon(llm,tmpvar,tmpvarbar) + zphibar(ig0,:) = tmpvarbar + ig0 = ig0+1 + do i=2,iim + zphisbar(ig0) = zphisbar(ig0-1) + zphibar(ig0,:) = zphibar(ig0-1,:) + ig0 = ig0+1 + enddo + enddo + tmpvar(:,1) = pphis(:,jjp1) + call moyzon(1,tmpvar(:,1),tmpvarbar(1)) + zphisbar(ngridmx) = tmpvarbar(1) + tmpvar(:,:) = pphi(:,jjp1,:) + call moyzon(llm,tmpvar,tmpvarbar) + zphibar(ngridmx,:) = tmpvarbar + endif + +c .... Calcul de la vitesse verticale ( en Pa*m*s ou Kg/s ) .... +c JG : ancien calcule de omega utilise dans physiq.F. Maintenant le flux +c de masse est calclue dans advtrac.F +c DO l=1,llm +c pvervel(1,l)=pw(1,1,l) * g /apoln +c ig0=2 +c DO j=2,jjm +c DO i = 1, iim +c pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j) +c ig0 = ig0 + 1 +c ENDDO +c ENDDO +c pvervel(ig0,l)=pw(1,jjp1,l) * g /apols +c ENDDO + +c +c 45. champ u: +c ------------ + + DO 50 l=1,llm + + DO 25 j=2,jjm + ig0 = 1+(j-2)*iim + zufi(ig0+1,l)= 0.5 * + $ ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) ) +! pcvgu(ig0+1,l)= 0.5 * +! $ ( pducov(iim,j,l)/cu(iim,j) + pducov(1,j,l)/cu(1,j) ) + DO 10 i=2,iim + zufi(ig0+i,l)= 0.5 * + $ ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) ) +! pcvgu(ig0+i,l)= 0.5 * +! $ ( pducov(i-1,j,l)/cu(i-1,j) + pducov(i,j,l)/cu(i,j) ) +10 CONTINUE +25 CONTINUE + +50 CONTINUE + + +c 46.champ v: +c ----------- + + DO l=1,llm + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + zvfi(ig0+i,l)= 0.5 * + $ ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) ) +c pcvgv(ig0+i,l)= 0.5 * +c $ ( pdvcov(i,j-1,l)/cv(i,j-1) + pdvcov(i,j,l)/cv(i,j) ) + ENDDO + ENDDO + ENDDO + + +c 47. champs de vents aux pole nord +c ------------------------------ +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1) + z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1) + z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zcosbis(i)= COS(rlonv(i))*z1bis(i) + zsin(i) = SIN(rlonv(i))*z1(i) + zsinbis(i)= SIN(rlonv(i))*z1bis(i) + ENDDO + + zufi(1,l) = SSUM(iim,zcos,1)/pi +! pcvgu(1,l) = SSUM(iim,zcosbis,1)/pi + zvfi(1,l) = SSUM(iim,zsin,1)/pi +! pcvgv(1,l) = SSUM(iim,zsinbis,1)/pi + + ENDDO + + +c 48. champs de vents aux pole sud: +c --------------------------------- +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm) + z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm) + z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zcosbis(i) = COS(rlonv(i))*z1bis(i) + zsin(i) = SIN(rlonv(i))*z1(i) + zsinbis(i) = SIN(rlonv(i))*z1bis(i) + ENDDO + + zufi(ngridmx,l) = SSUM(iim,zcos,1)/pi +! pcvgu(ngridmx,l) = SSUM(iim,zcosbis,1)/pi + zvfi(ngridmx,l) = SSUM(iim,zsin,1)/pi +! pcvgv(ngridmx,l) = SSUM(iim,zsinbis,1)/pi + + ENDDO +c +c On change de grille, dynamique vers physiq, pour le flux de masse verticale + CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi) + +c----------------------------------------------------------------------- +c Appel de la physique: +c --------------------- + +! Appel de la physique: pose probleme quand on tourne +! SANS physique, car physiq.F est dans le repertoire phy[]... +! Il faut une cle CPP_PHYS + +! Le fait que les arguments de physiq soient differents selon les planetes +! ne pose pas de probleme a priori. + +! write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys + zdt_split=dtphys/nsplit_phys + zdufic(:,:)=0. + zdvfic(:,:)=0. + zdtfic(:,:)=0. + zdqfic(:,:,:)=0. + +#ifdef CPP_PHYS + + do isplit=1,nsplit_phys + + jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys) + debut_split=debut.and.isplit==1 + lafin_split=lafin.and.isplit==nsplit_phys + + if (planet_type.eq."earth") then + CALL physiq (ngridmx, + . llm, + . debut_split, + . lafin_split, + . jD_cur, + . jH_cur_split, + . zdt_split, + . zplev, + . zplay, + . zphi, + . zphis, + . presnivs, + . zufi, + . zvfi, + . ztfi, + . zqfi, + . flxwfi, + . zdufi, + . zdvfi, + . zdtfi, + . zdqfi, + . zdpsrf, + . pducov) + + else if ( planet_type=="generic" ) then + + CALL physiq (ngridmx, !! ngrid + . llm, !! nlayer + . nqtot, !! nq + . tname, !! tracer names from dynamical core (given in infotrac) + . debut_split, !! firstcall + . lafin_split, !! lastcall + . jD_cur, !! pday. see leapfrog + . jH_cur_split, !! ptime "fraction of day" + . zdt_split, !! ptimestep + . zplev, !! pplev + . zplay, !! pplay + . zphi, !! pphi + . zufi, !! pu + . zvfi, !! pv + . ztfi, !! pt + . zqfi, !! pq + . flxwfi, !! pw !! or 0. anyway this is for diagnostic. not used in physiq. + . zdufi, !! pdu + . zdvfi, !! pdv + . zdtfi, !! pdt + . zdqfi, !! pdq + . zdpsrf, !! pdpsrf + . tracerdyn) !! tracerdyn <-- utilite ??? + + else if ( planet_type=="mars" ) then + + CALL physiq (ngridmx, ! ngrid + . llm, ! nlayer + . nqtot, ! nq + . debut_split, ! firstcall + . lafin_split, ! lastcall + . jD_cur, ! pday + . jH_cur_split, ! ptime + . zdt_split, ! ptimestep + . zplev, ! pplev + . zplay, ! pplay + . zphi, ! pphi + . zufi, ! pu + . zvfi, ! pv + . ztfi, ! pt + . zqfi, ! pq + . flxwfi, ! pw + . zdufi, ! pdu + . zdvfi, ! pdv + . zdtfi, ! pdt + . zdqfi, ! pdq + . zdpsrf, ! pdpsrf + . tracerdyn) ! tracerdyn (somewhat obsolete) + + else if ((planet_type=="titan").or.(planet_type=="venus")) then + + CALL physiq (ngridmx, + . llm, + . nqtot, + . debut_split, + . lafin_split, + . jD_cur, + . jH_cur_split, + . zdt_split, + . zplev, + . zplay, + . zpk, + . zphi, + . zphis, + . presnivs, + . zufi, + . zvfi, + . ztfi, + . zqfi, + . flxwfi, + . zdufi, + . zdvfi, + . zdtfi, + . zdqfi, + . zdpsrf) + + else ! unknown "planet_type" + + write(lunout,*) "calfis_p: error, unknown planet_type: ", + & trim(planet_type) + stop + + endif ! planet_type + + zufi(:,:)=zufi(:,:)+zdufi(:,:)*zdt_split + zvfi(:,:)=zvfi(:,:)+zdvfi(:,:)*zdt_split + ztfi(:,:)=ztfi(:,:)+zdtfi(:,:)*zdt_split + zqfi(:,:,:)=zqfi(:,:,:)+zdqfi(:,:,:)*zdt_split + + zdufic(:,:)=zdufic(:,:)+zdufi(:,:) + zdvfic(:,:)=zdvfic(:,:)+zdvfi(:,:) + zdtfic(:,:)=zdtfic(:,:)+zdtfi(:,:) + zdqfic(:,:,:)=zdqfic(:,:,:)+zdqfi(:,:,:) + + enddo ! of do isplit=1,nsplit_phys + +! ATTENTION... + if (flag_moyzon.and.(nsplit_phys.ne.1)) then + print*,"WARNING ! flag_moyzon + nsplit_phys" + print*,"zqfibar n'est pas implemente au cours des iterations" + print*,"Donc a revoir..." + stop + endif + +#endif +! #endif of #ifdef CPP_PHYS + + zdufi(:,:)=zdufic(:,:)/nsplit_phys + zdvfi(:,:)=zdvfic(:,:)/nsplit_phys + zdtfi(:,:)=zdtfic(:,:)/nsplit_phys + zdqfi(:,:,:)=zdqfic(:,:,:)/nsplit_phys + + +500 CONTINUE + +c----------------------------------------------------------------------- +c transformation des tendances physiques en tendances dynamiques: +c --------------------------------------------------------------- + +c tendance sur la pression : +c ----------------------------------- + + CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi) +c +c 62. enthalpie potentielle +c --------------------- + +! ADAPTATION GCM POUR CP(T) + call t2tpot(ngridmx*llm,ztfi,zteta,zpk) + + DO i=1,iip1 + pdhfi(i,1,:) = (zteta(1,:) - pteta(i,1,:))/dtphys + pdhfi(i,jjp1,:) = (zteta(ngridmx,:) - pteta(i,jjp1,:))/dtphys + ENDDO + + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + pdhfi(i,j,:) = (zteta(ig0+i,:) - pteta(i,j,:))/dtphys + ENDDO + pdhfi(iip1,j,:) = pdhfi(1,j,:) + ENDDO + + +c 62. humidite specifique +c --------------------- +! Ehouarn: removed this useless bit: was overwritten at step 63 anyways +! DO iq=1,nqtot +! DO l=1,llm +! DO i=1,iip1 +! pdqfi(i,1,l,iq) = zdqfi(1,l,iq) +! pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq) +! ENDDO +! DO j=2,jjm +! ig0=1+(j-2)*iim +! DO i=1,iim +! pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq) +! ENDDO +! pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq) +! ENDDO +! ENDDO +! ENDDO + +c 63. traceurs (tous en intensifs) +c ------------ +C initialisation des tendances + pdqfi(:,:,:,:)=0. +C + DO iq=1,nqtot + iiq=niadv(iq) + DO l=1,llm + DO i=1,iip1 + pdqfi(i,1,l,iiq) = zdqfi(1,l,iq) + pdqfi(i,jjp1,l,iiq) = zdqfi(ngridmx,l,iq) + ENDDO + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + pdqfi(i,j,l,iiq) = zdqfi(ig0+i,l,iq) + ENDDO + pdqfi(iip1,j,l,iiq) = pdqfi(1,j,l,iq) + ENDDO + ENDDO + ENDDO + +c 65. champ u: +c ------------ + + DO l=1,llm + + DO i=1,iip1 + pdufi(i,1,l) = 0. + pdufi(i,jjp1,l) = 0. + ENDDO + + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim-1 + pdufi(i,j,l)= + $ 0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j) + ENDDO + pdufi(iim,j,l)= + $ 0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j) + pdufi(iip1,j,l)=pdufi(1,j,l) + ENDDO + + ENDDO + + +c 67. champ v: +c ------------ + + DO l=1,llm + + DO j=2,jjm-1 + ig0=1+(j-2)*iim + DO i=1,iim + pdvfi(i,j,l)= + $ 0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j) + ENDDO + pdvfi(iip1,j,l) = pdvfi(1,j,l) + ENDDO + ENDDO + + +c 68. champ v pres des poles: +c --------------------------- +c v = U * cos(long) + V * SIN(long) + + DO l=1,llm + + DO i=1,iim + pdvfi(i,1,l)= + $ zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i)) + pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i)) + $ +zdvfi(ngridmx,l)*SIN(rlonv(i)) + pdvfi(i,1,l)= + $ 0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1) + pdvfi(i,jjm,l)= + $ 0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm) + ENDDO + + pdvfi(iip1,1,l) = pdvfi(1,1,l) + pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l) + + ENDDO + +c----------------------------------------------------------------------- + +700 CONTINUE + + firstcal = .FALSE. + +#endif +! of #ifndef CPP_PARA + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/calfis_p.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/calfis_p.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/calfis_p.F (revision 1540) @@ -0,0 +1,1443 @@ +! +! $Id: calfis_p.F 1407 2010-07-07 10:31:52Z fairhead $ +! +C +C + SUBROUTINE calfis_p(lafin, + $ jD_cur, jH_cur, + $ pucov, + $ pvcov, + $ pteta, + $ pq, + $ pmasse, + $ pps, + $ pp, + $ ppk, + $ pphis, + $ pphi, + $ pducov, + $ pdvcov, + $ pdteta, + $ pdq, + $ flxw, + $ pdufi, + $ pdvfi, + $ pdhfi, + $ pdqfi, + $ pdpsfi) +#ifdef CPP_PHYS +! Ehouarn: if using (parallelized) physics + USE dimphy + USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root + USE mod_interface_dyn_phys +! USE IOPHY +#endif +#ifdef CPP_PARA + USE parallel_lmdz, ONLY : omp_chunk, using_mpi, AllGather_Field + USE Write_Field + Use Write_field_p + USE Times + USE cpdet_mod, only: tpot2t_p, t2tpot_p +! used only for zonal averages + USE moyzon_mod +#endif + USE infotrac, ONLY: nqtot, niadv, tname + USE control_mod, ONLY: planet_type, nsplit_phys + USE comvert_mod, ONLY: preff,presnivs + USE comconst_mod, ONLY: daysec,dtvr,dtphys,kappa,cpp,g,rad,pi + USE logic_mod, ONLY: moyzon_ch,moyzon_mu + + IMPLICIT NONE +c======================================================================= +c +c 1. rearrangement des tableaux et transformation +c variables dynamiques > variables physiques +c 2. calcul des termes physiques +c 3. retransformation des tendances physiques en tendances dynamiques +c +c remarques: +c ---------- +c +c - les vents sont donnes dans la physique par leurs composantes +c naturelles. +c - la variable thermodynamique de la physique est une variable +c intensive : T +c pour la dynamique on prend T * ( preff / p(l) ) **kappa +c - les deux seules variables dependant de la geometrie necessaires +c pour la physique sont la latitude pour le rayonnement et +c l'aire de la maille quand on veut integrer une grandeur +c horizontalement. +c - les points de la physique sont les points scalaires de la +c la dynamique; numerotation: +c 1 pour le pole nord +c (jjm-1)*iim pour l'interieur du domaine +c ngridmx pour le pole sud +c ---> ngridmx=2+(jjm-1)*iim +c +c Input : +c ------- +c ecritphy frequence d'ecriture (en jours)de histphy +c pucov covariant zonal velocity +c pvcov covariant meridional velocity +c pteta potential temperature +c pps surface pressure +c pmasse masse d'air dans chaque maille +c pts surface temperature (K) +c callrad clef d'appel au rayonnement +c +c Output : +c -------- +c pdufi tendency for the natural zonal velocity (ms-1) +c pdvfi tendency for the natural meridional velocity +c pdhfi tendency for the potential temperature (K/s) +c pdtsfi tendency for the surface temperature +c +c pdtrad radiative tendencies \ both input +c pfluxrad radiative fluxes / and output +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ + + include "dimensions.h" + include "paramet.h" + + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + + include "comgeom2.h" + include "iniprint.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif +c Arguments : +c ----------- + LOGICAL,INTENT(IN) :: lafin ! .true. for the very last call to physics + REAL,INTENT(IN) :: jD_cur, jH_cur + REAL,INTENT(IN) :: pvcov(iip1,jjm,llm) ! covariant meridional velocity + REAL,INTENT(IN) :: pucov(iip1,jjp1,llm) ! covariant zonal velocity + REAL,INTENT(IN) :: pteta(iip1,jjp1,llm) ! potential temperature + REAL,INTENT(IN) :: pmasse(iip1,jjp1,llm) ! mass in each cell ! not used + REAL,INTENT(IN) :: pq(iip1,jjp1,llm,nqtot) ! tracers + REAL,INTENT(IN) :: pphis(iip1,jjp1) ! surface geopotential + REAL,INTENT(IN) :: pphi(iip1,jjp1,llm) ! geopotential + + REAL,INTENT(IN) :: pdvcov(iip1,jjm,llm) ! dynamical tendency on vcov + REAL,INTENT(IN) :: pducov(iip1,jjp1,llm) ! dynamical tendency on ucov + REAL,INTENT(IN) :: pdteta(iip1,jjp1,llm) ! dynamical tendency on teta +! commentaire SL: pdq ne sert que pour le calcul de pcvgq, +! qui lui meme ne sert a rien dans la routine telle qu'elle est +! ecrite, et que j'ai donc commente.... + REAL,INTENT(IN) :: pdq(iip1,jjp1,llm,nqtot) ! dynamical tendency on tracers + ! NB: pdq is only used to compute pcvgq which is in fact not used... + + REAL,INTENT(IN) :: pps(iip1,jjp1) ! surface pressure (Pa) + REAL,INTENT(IN) :: pp(iip1,jjp1,llmp1) ! pressure at mesh interfaces (Pa) + REAL,INTENT(IN) :: ppk(iip1,jjp1,llm) ! Exner at mid-layer + REAL,INTENT(IN) :: flxw(iip1,jjp1,llm) ! Vertical mass flux on lower mesh interfaces (kg/s) (on llm because flxw(:,:,llm+1)=0) + + ! tendencies (in */s) from the physics + REAL,INTENT(OUT) :: pdvfi(iip1,jjm,llm) ! tendency on covariant meridional wind + REAL,INTENT(OUT) :: pdufi(iip1,jjp1,llm) ! tendency on covariant zonal wind + REAL,INTENT(OUT) :: pdhfi(iip1,jjp1,llm) ! tendency on potential temperature (K/s) + REAL,INTENT(OUT) :: pdqfi(iip1,jjp1,llm,nqtot) ! tendency on tracers + REAL,INTENT(OUT) :: pdpsfi(iip1,jjp1) ! tendency on surface pressure (Pa/s) + +#ifdef CPP_PARA +#ifdef CPP_PHYS +c Local variables : +c ----------------- + + INTEGER i,j,l,ig0,ig,iq,iiq + REAL,ALLOCATABLE,SAVE :: zpsrf(:) + REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:) + REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:) + + REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:) + REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:) +! ADAPTATION GCM POUR CP(T) + REAL,ALLOCATABLE,SAVE :: zteta(:,:) + REAL,ALLOCATABLE,SAVE :: zpk(:,:) + +! Ces calculs ne servent pas. +! Si necessaire, decommenter ces variables et les calculs... +! REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:) +! REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:) +c + REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:) + REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdpsrf(:) + REAL,SAVE,ALLOCATABLE :: flxwfi(:,:) ! Flux de masse verticale sur la grille physiq + + REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zpk_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zphis_omp(:) + REAL,ALLOCATABLE,SAVE :: presnivs_omp(:) + REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:) + REAL,SAVE,ALLOCATABLE :: flxwfi_omp(:,:) ! Flux de masse verticale sur la grille physiq + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Introduction du splitting (FH) +! Question pour Yann : +! J'ai été surpris au début que les tableaux zufi_omp, zdufi_omp n'co soitent +! en SAVE. Je crois comprendre que c'est parce que tu voulais qu'il +! soit allocatable (plutot par exemple que de passer une dimension +! dépendant du process en argument des routines) et que, du coup, +! le SAVE évite d'avoir à refaire l'allocation à chaque appel. +! Tu confirmes ? +! J'ai suivi le même principe pour les zdufic_omp +! Mais c'est surement bien que tu controles. +! + + REAL,ALLOCATABLE,SAVE :: zdufic_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdvfic_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdtfic_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdqfic_omp(:,:,:) + REAL jH_cur_split,zdt_split + LOGICAL debut_split,lafin_split + INTEGER isplit +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zpk_omp,zphi_omp,zphis_omp, +c$OMP+ presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp, +c$OMP+ zqfi_omp,zdufi_omp,zdvfi_omp, +c$OMP+ zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp, +c$OMP+ zdufic_omp,zdvfic_omp,zdtfic_omp,zdqfic_omp) + + LOGICAL,SAVE :: first_omp=.true. +c$OMP THREADPRIVATE(first_omp) + + REAL zsin(iim),zcos(iim),z1(iim) + REAL zsinbis(iim),zcosbis(iim),z1bis(iim) + REAL unskap, pksurcp + save unskap + + REAL SSUM + + LOGICAL,SAVE :: firstcal=.true., debut=.true. +c$OMP THREADPRIVATE(firstcal,debut) + + REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv + INTEGER :: ierr +#ifdef CPP_MPI + INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status +#else + INTEGER,dimension(1,4) :: Status +#endif + INTEGER, dimension(4) :: Req + REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:) + integer :: k,kstart,kend + INTEGER :: offset + + LOGICAL tracerdyn ! for generic/mars physics call ; possibly to get rid of + +! For Titan only right now: +! to allow for 2D computation of microphys and chemistry + LOGICAL,save :: flag_moyzon + REAL,allocatable,save :: tmpvar(:,:) + REAL,allocatable,save :: tmpvarp1(:,:) + REAL,allocatable,save :: tmpvarbar(:) + REAL,allocatable,save :: tmpvarbarp1(:) + real :: zz1,zz2 + +c----------------------------------------------------------------------- + +c 1. Initialisations : +c -------------------- + + + klon=klon_mpi + + IF ( firstcal ) THEN + debut = .TRUE. + IF (ngridmx.NE.2+(jjm-1)*iim) THEN + write(lunout,*) 'STOP dans calfis' + write(lunout,*) + & 'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim' + write(lunout,*) ' ngridmx jjm iim ' + write(lunout,*) ngridmx,jjm,iim + STOP + ENDIF + + unskap = 1./ kappa + +c$OMP MASTER + flag_moyzon = .false. + if(moyzon_ch.or.moyzon_mu) then + flag_moyzon = .true. + allocate(tmpvar(iip1,llm)) + allocate(tmpvarp1(iip1,llmp1)) + allocate(tmpvarbar(llm)) + allocate(tmpvarbarp1(llmp1)) + endif + + ALLOCATE(zpsrf(klon)) + ALLOCATE(zplev(klon,llm+1),zplay(klon,llm)) + ALLOCATE(zphi(klon,llm),zphis(klon)) + ALLOCATE(zufi(klon,llm), zvfi(klon,llm)) + ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot)) +! ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm)) +! ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2)) + ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm)) + ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot)) + ALLOCATE(zdpsrf(klon)) + ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm)) + ALLOCATE(flxwfi(klon,llm)) +! ADAPTATION GCM POUR CP(T) + ALLOCATE(zteta(klon,llm)) + ALLOCATE(zpk(klon,llm)) + + ! zonal means. horizontal dimension should be iip1 + if (flag_moyzon) call moyzon_init(klon,llm,nqtot) + +c------------------------------------------------------------------ +c moyennes globales pour les profils de pression et de temperature + if(planet_type.eq."titan".or.planet_type.eq."venus") then + call AllGather_Field(pp,iip1*jjp1,llmp1) + call AllGather_Field(pteta,iip1*jjp1,llm) + call AllGather_Field(ppk,iip1*jjp1,llm) + call AllGather_Field(pphi,iip1*jjp1,llm) + call AllGather_Field(pphis,iip1*jjp1,1) + ALLOCATE(plevmoy(llm+1)) + ALLOCATE(playmoy(llm)) + ALLOCATE(tmoy(llm)) + ALLOCATE(tetamoy(llm)) + ALLOCATE(pkmoy(llm)) + ALLOCATE(phimoy(0:llm)) + ALLOCATE(zlevmoy(llm+1)) + ALLOCATE(zlaymoy(llm)) + plevmoy=0. + do l=1,llmp1 + do i=1,iip1 + do j=1,jjp1 + plevmoy(l)=plevmoy(l)+pp(i,j,l)/(iip1*jjp1) + enddo + enddo + enddo + tetamoy=0. + pkmoy=0. + phimoy=0. + do i=1,iip1 + do j=1,jjp1 + phimoy(0)=phimoy(0)+pphis(i,j)/(iip1*jjp1) + enddo + enddo + do l=1,llm + do i=1,iip1 + do j=1,jjp1 + tetamoy(l)=tetamoy(l)+pteta(i,j,l)/(iip1*jjp1) + pkmoy(l)=pkmoy(l)+ppk(i,j,l)/(iip1*jjp1) + phimoy(l)=phimoy(l)+pphi(i,j,l)/(iip1*jjp1) + enddo + enddo + enddo + playmoy(:) = preff * (pkmoy(:)/cpp) ** unskap + call tpot2t_p(1,llm,tetamoy,tmoy,pkmoy) +c SI ON TIENT COMPTE DE LA VARIATION DE G AVEC L'ALTITUDE: + zlaymoy(1:llm) = g*rad*rad/(g*rad-phimoy(1:llm))-rad + zlevmoy(1) = phimoy(0)/g + DO l=2,llm + zz1=(playmoy(l-1)+plevmoy(l))/(playmoy(l-1)-plevmoy(l)) + zz2=(plevmoy(l) +playmoy(l))/(plevmoy(l) -playmoy(l)) + zlevmoy(l)=(zz1*zlaymoy(l-1)+zz2*zlaymoy(l))/(zz1+zz2) + ENDDO + zlevmoy(llmp1)=zlaymoy(llm)+(zlaymoy(llm)-zlevmoy(llm)) +c------------------- +c + lat index + allocate(klat(klon)) + do ig0=1,klon + j=index_j(ig0) + klat(ig0)=j + enddo + endif ! planet_type=titan +c------------------------------------------------------------------ + +c$OMP END MASTER +c$OMP BARRIER + ELSE + debut = .FALSE. + ENDIF + + +c----------------------------------------------------------------------- +c 40. transformation des variables dynamiques en variables physiques: +c --------------------------------------------------------------- + +c 41. pressions au sol (en Pascals) +c ---------------------------------- + +c$OMP MASTER + call start_timer(timer_physic) +c$OMP END MASTER + +c$OMP MASTER +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zpsrf(ig0)=pps(i,j) + enddo +c$OMP END MASTER + + +c 42. pression intercouches et fonction d'Exner: + +c ----------------------------------------------------------------- +c .... zplev definis aux (llm +1) interfaces des couches .... +c .... zplay definis aux ( llm ) milieux des couches .... +c ----------------------------------------------------------------- + +c ... Exner = cp * ( p(l) / preff ) ** kappa .... + +c print *,omp_rank,'klon--->',klon +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llmp1 +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zplev( ig0,l ) = pp(i,j,l) + enddo + ENDDO +c$OMP END DO NOWAIT + if (flag_moyzon) then + call AllGather_Field(pp,iip1*jjp1,llmp1) + j=index_j(1) + tmpvarp1(:,:) = pp(:,j,:) + call moyzon(llmp1,tmpvarp1,tmpvarbarp1) + zplevbar_mpi(1,:) = tmpvarbarp1 + do ig0=2,klon + j=index_j(ig0) + if (j.ne.index_j(ig0-1)) then + tmpvarp1(:,:) = pp(:,j,:) + call moyzon(llmp1,tmpvarp1,tmpvarbarp1) + zplevbar_mpi(ig0,:) = tmpvarbarp1 + else + zplevbar_mpi(ig0,:) = zplevbar_mpi(ig0-1,:) + endif + enddo + endif + +! ADAPTATION GCM POUR CP(T) +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zpk(ig0,l)=ppk(i,j,l) + zteta(ig0,l)=pteta(i,j,l) + enddo + ENDDO +c$OMP END DO NOWAIT + if (flag_moyzon) then + call AllGather_Field(pteta,iip1*jjp1,llm) + call AllGather_Field(ppk,iip1*jjp1,llm) + j=index_j(1) + tmpvar(:,:) = pteta(:,j,:) + call moyzon(llm,tmpvar,tmpvarbar) + ztetabar_mpi(1,:) = tmpvarbar + tmpvar(:,:) = ppk(:,j,:) + call moyzon(llm,tmpvar,tmpvarbar) + zpkbar_mpi(1,:) = tmpvarbar + call tpot2t_p(1,llm,ztetabar_mpi(1,:),ztfibar_mpi(1,:), + & zpkbar_mpi(1,:)) + do ig0=2,klon + j=index_j(ig0) + if (j.ne.index_j(ig0-1)) then + tmpvar(:,:) = pteta(:,j,:) + call moyzon(llm,tmpvar,tmpvarbar) + ztetabar_mpi(ig0,:) = tmpvarbar + tmpvar(:,:) = ppk(:,j,:) + call moyzon(llm,tmpvar,tmpvarbar) + zpkbar_mpi(ig0,:) = tmpvarbar + call tpot2t_p(1,llm,ztetabar_mpi(ig0,:),ztfibar_mpi(ig0,:), + & zpkbar_mpi(ig0,:)) + else + zpkbar_mpi(ig0,:) = zpkbar_mpi(ig0-1,:) + ztetabar_mpi(ig0,:) = ztetabar_mpi(ig0-1,:) + ztfibar_mpi(ig0,:) = ztfibar_mpi(ig0-1,:) + endif + enddo + endif + +c 43. temperature naturelle (en K) et pressions milieux couches . +c --------------------------------------------------------------- + +! ADAPTATION GCM POUR CP(T) + call tpot2t_p(klon,llm,zteta,ztfi,zpk) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + pksurcp = ppk(i,j,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap + enddo + ENDDO +c$OMP END DO NOWAIT + if (flag_moyzon) then + zplaybar_mpi(:,:) = preff * (zpkbar_mpi(:,:)/cpp)**unskap + endif + +c 43.bis traceurs (tous intensifs) +c --------------- + + DO iq=1,nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zqfi(ig0,l,iq) = pq(i,j,l,iq) + enddo + ENDDO +c$OMP END DO NOWAIT + ENDDO ! of DO iq=1,nqtot + if (flag_moyzon) then + DO iq=1,nqtot + call AllGather_Field(pq(:,:,:,iq),iip1*jjp1,llm) + j=index_j(1) + tmpvar(:,:) = pq(:,j,:,iq) + call moyzon(llm,tmpvar,tmpvarbar) + zqfibar_mpi(1,:,iq) = tmpvarbar + do ig0=2,klon + j=index_j(ig0) + if (j.ne.index_j(ig0-1)) then + tmpvar(:,:) = pq(:,j,:,iq) + call moyzon(llm,tmpvar,tmpvarbar) + zqfibar_mpi(ig0,:,iq) = tmpvarbar + else + zqfibar_mpi(ig0,:,iq) = zqfibar_mpi(ig0-1,:,iq) + endif + enddo + ENDDO ! of DO iq=1,nqtot + endif + + +c Geopotentiel calcule par rapport a la surface locale: +c ----------------------------------------------------- + + CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi) + + CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis) + +c$OMP BARRIER +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ig=1,klon + zphi(ig,l)=zphi(ig,l)-zphis(ig) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + if (flag_moyzon) then + call AllGather_Field(pphis,iip1*jjp1,1) + call AllGather_Field(pphi,iip1*jjp1,llm) + j=index_j(1) + tmpvar(:,1) = pphis(:,j) + call moyzon(1,tmpvar(:,1),tmpvarbar(1)) + zphisbar_mpi(1) = tmpvarbar(1) + tmpvar(:,:) = pphi(:,j,:) + call moyzon(llm,tmpvar,tmpvarbar) + zphibar_mpi(1,:) = tmpvarbar-zphisbar_mpi(1) + do ig0=2,klon + j=index_j(ig0) + if (j.ne.index_j(ig0-1)) then + tmpvar(:,1) = pphis(:,j) + call moyzon(1,tmpvar(:,1),tmpvarbar(1)) + zphisbar_mpi(ig0) = tmpvarbar(1) + tmpvar(:,:) = pphi(:,j,:) + call moyzon(llm,tmpvar,tmpvarbar) + zphibar_mpi(ig0,:) = tmpvarbar-zphisbar_mpi(ig0) + else + zphisbar_mpi(ig0) = zphisbar_mpi(ig0-1) + zphibar_mpi(ig0,:) = zphibar_mpi(ig0-1,:) + endif + enddo + endif + +c +c 45. champ u: +c ------------ + + kstart=1 + kend=klon + + if (is_north_pole) kstart=2 + if (is_south_pole) kend=klon-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) +!CDIR SPARSE + do ig0=kstart,kend + i=index_i(ig0) + j=index_j(ig0) + if (i==1) then + zufi(ig0,l)= 0.5 *( pucov(iim,j,l)/cu(iim,j) + $ + pucov(1,j,l)/cu(1,j) ) + else + zufi(ig0,l)= 0.5*( pucov(i-1,j,l)/cu(i-1,j) + $ + pucov(i,j,l)/cu(i,j) ) + endif + enddo + ENDDO +c$OMP END DO NOWAIT + +c 46.champ v: +c ----------- + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + DO ig0=kstart,kend + i=index_i(ig0) + j=index_j(ig0) + zvfi(ig0,l)= 0.5 *( pvcov(i,j-1,l)/cv(i,j-1) + $ + pvcov(i,j,l)/cv(i,j) ) + + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c 47. champs de vents aux pole nord +c ------------------------------ +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + if (is_north_pole) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zsin(i) = SIN(rlonv(i))*z1(i) + ENDDO + + zufi(1,l) = SSUM(iim,zcos,1)/pi + zvfi(1,l) = SSUM(iim,zsin,1)/pi + + ENDDO +c$OMP END DO NOWAIT + endif + + +c 48. champs de vents aux pole sud: +c --------------------------------- +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + if (is_south_pole) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zsin(i) = SIN(rlonv(i))*z1(i) + ENDDO + + zufi(klon,l) = SSUM(iim,zcos,1)/pi + zvfi(klon,l) = SSUM(iim,zsin,1)/pi + ENDDO +c$OMP END DO NOWAIT + endif + +c On change de grille, dynamique vers physiq, pour le flux de masse verticale + CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi) + +c----------------------------------------------------------------------- +c Appel de la physique: +c --------------------- + +! Appel de la physique: pose probleme quand on tourne +! SANS physique, car physiq.F est dans le repertoire phy[]... +! Il faut une cle CPP_PHYS + +! Le fait que les arguments de physiq soient differents selon les planetes +! ne pose pas de probleme a priori. + + +c$OMP BARRIER + if (first_omp) then + klon=klon_omp + + allocate(zplev_omp(klon,llm+1)) + allocate(zplay_omp(klon,llm)) + allocate(zpk_omp(klon,llm)) + allocate(zphi_omp(klon,llm)) + allocate(zphis_omp(klon)) + allocate(presnivs_omp(llm)) + allocate(zufi_omp(klon,llm)) + allocate(zvfi_omp(klon,llm)) + allocate(ztfi_omp(klon,llm)) + allocate(zqfi_omp(klon,llm,nqtot)) + allocate(zdufi_omp(klon,llm)) + allocate(zdvfi_omp(klon,llm)) + allocate(zdtfi_omp(klon,llm)) + allocate(zdqfi_omp(klon,llm,nqtot)) + allocate(zdufic_omp(klon,llm)) + allocate(zdvfic_omp(klon,llm)) + allocate(zdtfic_omp(klon,llm)) + allocate(zdqfic_omp(klon,llm,nqtot)) + allocate(zdpsrf_omp(klon)) + allocate(flxwfi_omp(klon,llm)) + + if (flag_moyzon) call moyzon_init_omp(klon,llm,nqtot) + + first_omp=.false. + endif + + + klon=klon_omp + offset=klon_omp_begin-1 + + do l=1,llm+1 + do i=1,klon + zplev_omp(i,l)=zplev(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zplay_omp(i,l)=zplay(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zpk_omp(i,l)=zpk(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zphi_omp(i,l)=zphi(offset+i,l) + enddo + enddo + + do i=1,klon + zphis_omp(i)=zphis(offset+i) + enddo + + + do l=1,llm + presnivs_omp(l)=presnivs(l) + enddo + + do l=1,llm + do i=1,klon + zufi_omp(i,l)=zufi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zvfi_omp(i,l)=zvfi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + ztfi_omp(i,l)=ztfi(offset+i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq) + enddo + enddo + enddo + + do l=1,llm + do i=1,klon + zdufi_omp(i,l)=zdufi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdvfi_omp(i,l)=zdvfi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdtfi_omp(i,l)=zdtfi(offset+i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq) + enddo + enddo + enddo + + do i=1,klon + zdpsrf_omp(i)=zdpsrf(offset+i) + enddo + + do l=1,llm + do i=1,klon + flxwfi_omp(i,l)=flxwfi(offset+i,l) + enddo + enddo + + if (flag_moyzon) then + do l=1,llm+1 + do i=1,klon + zplevbar(i,l)=zplevbar_mpi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zplaybar(i,l)=zplaybar_mpi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zphibar(i,l)=zphibar_mpi(offset+i,l) + enddo + enddo + + do i=1,klon + zphisbar(i)=zphisbar_mpi(offset+i) + enddo + + do l=1,llm + do i=1,klon + ztfibar(i,l)=ztfibar_mpi(offset+i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zqfibar(i,l,iq)=zqfibar_mpi(offset+i,l,iq) + enddo + enddo + enddo + endif + + +c$OMP BARRIER + +!$OMP MASTER +! write(lunout,*) 'PHYSIQUE AVEC NSPLIT_PHYS=',nsplit_phys +!$OMP END MASTER + zdt_split=dtphys/nsplit_phys + zdufic_omp(:,:)=0. + zdvfic_omp(:,:)=0. + zdtfic_omp(:,:)=0. + zdqfic_omp(:,:,:)=0. + +#ifdef CPP_PHYS + do isplit=1,nsplit_phys + + jH_cur_split=jH_cur+(isplit-1) * dtvr / (daysec *nsplit_phys) + debut_split=debut.and.isplit==1 + lafin_split=lafin.and.isplit==nsplit_phys + + + if (planet_type=="earth") then + CALL physiq (klon, + . llm, + . debut_split, + . lafin_split, + . jD_cur, + . jH_cur_split, + . zdt_split, + . zplev_omp, + . zplay_omp, + . zphi_omp, + . zphis_omp, + . presnivs_omp, + . zufi_omp, + . zvfi_omp, + . ztfi_omp, + . zqfi_omp, + . flxwfi_omp, + . zdufi_omp, + . zdvfi_omp, + . zdtfi_omp, + . zdqfi_omp, + . zdpsrf_omp, + . pducov) + + else if ( planet_type=="generic" ) then + + CALL physiq (klon, !! ngrid + . llm, !! nlayer + . nqtot, !! nq + . tname, !! tracer names from dynamical core (given in infotrac) + . debut_split, !! firstcall + . lafin_split, !! lastcall + . jD_cur, !! pday. see leapfrog_p + . jH_cur_split, !! ptime "fraction of day" + . zdt_split, !! ptimestep + . zplev_omp, !! pplev + . zplay_omp, !! pplay + . zphi_omp, !! pphi + . zufi_omp, !! pu + . zvfi_omp, !! pv + . ztfi_omp, !! pt + . zqfi_omp, !! pq + . flxwfi_omp, !! pw !! or 0. anyway this is for diagnostic. not used in physiq. + . zdufi_omp, !! pdu + . zdvfi_omp, !! pdv + . zdtfi_omp, !! pdt + . zdqfi_omp, !! pdq + . zdpsrf_omp, !! pdpsrf + . tracerdyn) !! tracerdyn <-- utilite ??? + + else if ( planet_type=="mars" ) then + + CALL physiq (klon, ! ngrid + . llm, ! nlayer + . nqtot, ! nq + . debut_split, ! firstcall + . lafin_split, ! lastcall + . jD_cur, ! pday + . jH_cur_split, ! ptime + . zdt_split, ! ptimestep + . zplev_omp, ! pplev + . zplay_omp, ! pplay + . zphi_omp, ! pphi + . zufi_omp, ! pu + . zvfi_omp, ! pv + . ztfi_omp, ! pt + . zqfi_omp, ! pq + . flxwfi_omp, ! pw + . zdufi_omp, ! pdu + . zdvfi_omp, ! pdv + . zdtfi_omp, ! pdt + . zdqfi_omp, ! pdq + . zdpsrf_omp, ! pdpsrf + . tracerdyn) ! tracerdyn (somewhat obsolete) + + else if ((planet_type=="titan").or.(planet_type=="venus")) then + + CALL physiq (klon, + . llm, + . nqtot, + . debut_split, + . lafin_split, + . jD_cur, + . jH_cur_split, + . zdt_split, + . zplev_omp, + . zplay_omp, + . zpk_omp, + . zphi_omp, + . zphis_omp, + . presnivs_omp, + . zufi_omp, + . zvfi_omp, + . ztfi_omp, + . zqfi_omp, + . flxwfi_omp, + . zdufi_omp, + . zdvfi_omp, + . zdtfi_omp, + . zdqfi_omp, + . zdpsrf_omp) + + else ! unknown "planet_type" + + write(lunout,*) "calfis_p: error, unknown planet_type: ", + & trim(planet_type) + stop + + endif ! planet_type + zufi_omp(:,:)=zufi_omp(:,:)+zdufi_omp(:,:)*zdt_split + zvfi_omp(:,:)=zvfi_omp(:,:)+zdvfi_omp(:,:)*zdt_split + ztfi_omp(:,:)=ztfi_omp(:,:)+zdtfi_omp(:,:)*zdt_split + zqfi_omp(:,:,:)=zqfi_omp(:,:,:)+zdqfi_omp(:,:,:)*zdt_split + + zdufic_omp(:,:)=zdufic_omp(:,:)+zdufi_omp(:,:) + zdvfic_omp(:,:)=zdvfic_omp(:,:)+zdvfi_omp(:,:) + zdtfic_omp(:,:)=zdtfic_omp(:,:)+zdtfi_omp(:,:) + zdqfic_omp(:,:,:)=zdqfic_omp(:,:,:)+zdqfi_omp(:,:,:) + + enddo + +#endif +! of #ifdef CPP_PHYS + + zdufi_omp(:,:)=zdufic_omp(:,:)/nsplit_phys + zdvfi_omp(:,:)=zdvfic_omp(:,:)/nsplit_phys + zdtfi_omp(:,:)=zdtfic_omp(:,:)/nsplit_phys + zdqfi_omp(:,:,:)=zdqfic_omp(:,:,:)/nsplit_phys + +c$OMP BARRIER + + do l=1,llm+1 + do i=1,klon + zplev(offset+i,l)=zplev_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zplay(offset+i,l)=zplay_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zphi(offset+i,l)=zphi_omp(i,l) + enddo + enddo + + + do i=1,klon + zphis(offset+i)=zphis_omp(i) + enddo + + + do l=1,llm + presnivs(l)=presnivs_omp(l) + enddo + + do l=1,llm + do i=1,klon + zufi(offset+i,l)=zufi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zvfi(offset+i,l)=zvfi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + ztfi(offset+i,l)=ztfi_omp(i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq) + enddo + enddo + enddo + + do l=1,llm + do i=1,klon + zdufi(offset+i,l)=zdufi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdvfi(offset+i,l)=zdvfi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdtfi(offset+i,l)=zdtfi_omp(i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq) + enddo + enddo + enddo + + do i=1,klon + zdpsrf(offset+i)=zdpsrf_omp(i) + enddo + + + klon=klon_mpi +500 CONTINUE +c$OMP BARRIER + +c$OMP MASTER + call stop_timer(timer_physic) +c$OMP END MASTER + + IF (using_mpi) THEN + + if (MPI_rank>0) then + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + du_send(1:iim,l)=zdufi(1:iim,l) + dv_send(1:iim,l)=zdvfi(1:iim,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER +#ifdef CPP_MPI +c$OMP MASTER +!$OMP CRITICAL (MPI) + call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401, + & COMM_LMDZ,Req(1),ierr) + call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402, + & COMM_LMDZ,Req(2),ierr) +!$OMP END CRITICAL (MPI) +c$OMP END MASTER +#endif +c$OMP BARRIER + + endif + + if (MPI_rank0 .and. MPI_rank< MPI_Size-1) then + call MPI_WAITALL(4,Req(1),Status,ierr) + else if (MPI_rank>0) then + call MPI_WAITALL(2,Req(1),Status,ierr) + else if (MPI_rank thresh).AND. & + (y_i(ji)-c(jo)>thresh.OR.y_i(ji)-d(jo)thresh).AND. & + (x_i(ii)-a(io)>thresh.OR.x_i(ii)-b(io)=1) PRINT*, "Problem: point out of domain (i,j)=", io,jo + CALL dist_sphe(x_o(io),y_o(jo),x_i,y_i,dist(:,:)) + nr=MINLOC(dist(:,:))!; IF(prt_level>=1) PRINT*, "Solution: ", nr + inc=1.0; IF(li) inc=d_i(nr(1),nr(2)) + IF(mask(nr(1),nr(2))) d_o1(io,jo)=inc + END DO + END DO + +END SUBROUTINE fine2coarse +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE grille_m(xdata, ydata, entree, x, y, sortie) +! +!------------------------------------------------------------------------------- +! Author: Z.X. Li (april 1st 1994) (see also A. Harzallah and L. Fairhead) +!------------------------------------------------------------------------------- +! Purpose: Naive method to regrid on a coarser grid. +! Value at a new point is an average of the old points lcoated in a zone +! surrounding the considered new point. +! No ponderation is used (see grille_p) +! +! (c) +! ----d----- +! | . . . .| +! | | +! (b)a . * . .b(a) +! | | +! | . . . .| +! ----c----- +! (d) +! +!------------------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: + REAL, INTENT(IN) :: xdata(:), ydata(:) !--- INPUT FIELD X AND Y COORD. + REAL, INTENT(IN) :: entree(SIZE(xdata),SIZE(ydata)) !--- INPUT FIELD + REAL, INTENT(IN) :: x(:), y(:) !--- OUTPUT FIELD X AND Y COORD. + REAL, INTENT(OUT) :: sortie(SIZE(x),SIZE(y)) !--- OUTPUT FIELD +!------------------------------------------------------------------------------- + CALL fine2coarse(xdata,ydata,x,y,sortie,entree) + +END SUBROUTINE grille_m +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE rugosite(xdata, ydata, entree, x, y, sortie, mask) +! +!------------------------------------------------------------------------------- +! Author: Z.X. Li (april 1st 1994) +!------------------------------------------------------------------------------- +! Purpose: Remap rugosity length ; constant value (0.001) on oceans. +! Naive method (see grille_m) +!------------------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: + REAL, INTENT(IN) :: xdata(:), ydata(:) !--- INPUT FIELD X AND Y COORD. + REAL, INTENT(IN) :: entree(SIZE(xdata),SIZE(ydata)) !--- INPUT FIELD + REAL, INTENT(IN) :: x(:), y(:) !--- OUTPUT FIELD X AND Y COORD. + REAL, INTENT(OUT) :: sortie(SIZE(x),SIZE(y)) !--- OUTPUT FIELD + REAL, INTENT(IN) :: mask (SIZE(x),SIZE(y)) !--- MASK +!------------------------------------------------------------------------------- + CALL fine2coarse(xdata,ydata,x,y,sortie,LOG(entree)) + WHERE(NINT(mask)==1) + sortie(:,:)=EXP(sortie(:,:)) + ELSE WHERE + sortie(:,:)=0.001 + END WHERE + +END SUBROUTINE rugosite +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE sea_ice(xdata, ydata, glace01, x, y, frac_ice) +! +!------------------------------------------------------------------------------- +! Author: Z.X. Li (april 1st 1994) +! Purpose: Regrid ice indicator (0 or 1) on a coarser grid to get an ice fract. +! field (between 0 and 1). +! Naive method (see grille_m) +!------------------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: + REAL, INTENT(IN) :: xdata(:), ydata(:) !--- INPUT FIELD X AND Y COORD. + REAL, INTENT(IN) :: glace01(:,:) !--- INPUT FIELD + REAL, INTENT(IN) :: x(:), y(:) !--- OUTPUT FIELD X AND Y COORD. + REAL, INTENT(OUT) :: frac_ice(SIZE(x),SIZE(y)) !--- OUTPUT FIELD +!------------------------------------------------------------------------------- + CALL fine2coarse(xdata,ydata,x,y,frac_ice,msk=NINT(glace01)==1) + +END SUBROUTINE sea_ice +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE rugsoro(xrel, yrel, relief, xmod, ymod, rugs) +! +!------------------------------------------------------------------------------- +! Author: Z.X. Li (april 1st 1994) ; Modifications: august 23rd 1995. +! Purpose: Compute rugosity due to orography by using standard dev in a 1x1 cell +!------------------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: + REAL, INTENT(IN) :: xrel(:), yrel(:) !--- INPUT FIELD X AND Y COORD. + REAL, INTENT(IN) :: relief(:,:) !--- INPUT FIELD + REAL, INTENT(IN) :: xmod(:), ymod(:) !--- OUTPUT FIELD X AND Y COORD. + REAL, INTENT(OUT) :: rugs(SIZE(xmod),SIZE(ymod)) !--- OUTPUT FIELD +!------------------------------------------------------------------------------- +! Local variable: + INTEGER :: k, nn + INTEGER, PARAMETER:: itmp=360, jtmp=180 + REAL :: out(SIZE(xmod),SIZE(xmod)), amin, amax + REAL :: cham1tmp(itmp,jtmp), cham2tmp(itmp,jtmp), xtmp(itmp), ytmp(jtmp) +!------------------------------------------------------------------------------- + +!--- TEST INPUT FILE FITS FOR ONE DEGREE RESOLUTION + xtmp(:)=4.0*ATAN(1.0)*[(-1.0+REAL(2*k-1)/REAL(itmp),k=1,itmp)] + ytmp(:)=2.0*ATAN(1.0)*[(-1.0+REAL(2*k-1)/REAL(jtmp),k=1,jtmp)] + CALL fine2coarse(xrel,yrel,xtmp,ytmp,cham1tmp,relief,d_o2=cham2tmp) + cham2tmp(:,:)=cham2tmp(:,:)-cham1tmp(:,:)**2 + nn=COUNT(cham2tmp<=-7.5) + IF(nn/=0) THEN + PRINT*,'Problem for rugsoro ; std**2 < -7.5 for several points: ',nn + CALL ABORT_GCM("", "", 1) + END IF + nn=COUNT(cham2tmp<0) + IF(nn/=0) PRINT*,'Problem for rugsoro ; std**2 < 0. for several points: ',nn + WHERE(cham2tmp<0.0) cham2tmp=0.0 + cham2tmp(:,:)=SQRT(cham2tmp(:,:)) + amin=MINVAL(cham2tmp); amax=MAXVAL(cham2tmp) + PRINT*, 'Ecart-type 1x1:', amin, amax + +!--- COMPUTE RUGOSITY AT REQUIRED SCALE + WHERE(cham2tmp<0.001) cham2tmp=0.001 + CALL fine2coarse(xtmp,ytmp,xmod,ymod,out,REAL(LOG(cham2tmp))) + out=EXP(out) + amin=MINVAL(out); amax=MAXVAL(out) + PRINT*, 'Ecart-type du modele:', amin, amax + out=out/amax*20.0 + amin=MINVAL(out); amax=MAXVAL(out) + PRINT*, 'Longueur de rugosite du modele:', amin, amax + rugs=REAL(out) + +END SUBROUTINE rugsoro +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE dist_sphe(rf_lon,rf_lat,rlon,rlat,distance) +! +!------------------------------------------------------------------------------- +! Author: Laurent Li (december 30th 1996). +! Purpose: Compute min. distance (along big circle) between 2 points in degrees. +!------------------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------------------- +! Arguments: + REAL, INTENT(IN) :: rf_lon, rf_lat !--- Reference point coordinates (degrees) + REAL, INTENT(IN) :: rlon(:), rlat(:)!--- Points longitudes/latitudes (degrees) + REAL, INTENT(OUT):: distance(SIZE(rlon),SIZE(rlat)) !--- Distance (degrees) +!------------------------------------------------------------------------------- +! Local variables: + LOGICAL, SAVE :: first=.TRUE. + REAL :: pa, pb, cpa, cpab, spa, spab, crlo(SIZE(rlon)) + INTEGER :: i, j +!------------------------------------------------------------------------------- + IF(first) THEN + pi=4.0*ATAN(1.0); deg2rad=pi/180.0; first=.FALSE. + END IF + crlo(:)=COS((rf_lon-rlon(:))*deg2rad) !--- COS of points 1 and 2 angle + pa=(90.0-rf_lat)*deg2rad !--- North Pole - Point 1 distance + cpa=COS(pa); spa=SIN(pa) + DO j=1,SIZE(rlat) + pb=(90.0-rlat(j))*deg2rad !--- North Pole - Point 2 distance + cpab=cpa*COS(pb); spab=spa*SIN(pb) + distance(:,j)=ACOS(cpab+spab*crlo(:))/deg2rad + END DO + +END SUBROUTINE dist_sphe +! +!------------------------------------------------------------------------------- + +END MODULE grid_atob_m +! +!******************************************************************************* + Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/mod_interface_dyn_phys.F90 =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/mod_interface_dyn_phys.F90 (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/mod_interface_dyn_phys.F90 (revision 1540) @@ -0,0 +1,59 @@ +! +! $Id: mod_interface_dyn_phys.F90 1615 2012-02-10 15:42:26Z emillour $ +! +MODULE mod_interface_dyn_phys + INTEGER,SAVE,dimension(:),allocatable :: index_i + INTEGER,SAVE,dimension(:),allocatable :: index_j + + +#ifdef CPP_PHYS +! Interface with parallel physics, +CONTAINS + + SUBROUTINE Init_interface_dyn_phys + USE mod_phys_lmdz_mpi_data, ONLY: klon_mpi, is_north_pole, is_south_pole, & + ii_begin, jj_begin, ii_end, jj_end + IMPLICIT NONE + include 'dimensions.h' + + INTEGER :: i,j,k + + ALLOCATE(index_i(klon_mpi)) + ALLOCATE(index_j(klon_mpi)) + + k=1 + IF (is_north_pole) THEN + index_i(k)=1 + index_j(k)=1 + k=2 + ELSE + DO i=ii_begin,iim + index_i(k)=i + index_j(k)=jj_begin + k=k+1 + ENDDO + ENDIF + + DO j=jj_begin+1,jj_end-1 + DO i=1,iim + index_i(k)=i + index_j(k)=j + k=k+1 + ENDDO + ENDDO + + IF (is_south_pole) THEN + index_i(k)=1 + index_j(k)=jj_end + ELSE + DO i=1,ii_end + index_i(k)=i + index_j(k)=jj_end + k=k+1 + ENDDO + ENDIF + + END SUBROUTINE Init_interface_dyn_phys +#endif +! of #ifdef CPP_PHYS +END MODULE mod_interface_dyn_phys Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phymars =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phymars (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phymars (revision 1540) @@ -0,0 +1,1 @@ +link ../../../LMDZ.MARS/libf/dynphy_lonlat/phymars Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phystd =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phystd (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phystd (revision 1540) @@ -0,0 +1,1 @@ +link ../../../LMDZ.GENERIC/libf/dynphy_lonlat/phystd Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/conf_dat3d.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/conf_dat3d.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/conf_dat3d.F (revision 1540) @@ -0,0 +1,296 @@ +! +! $Header$ +! +C +C + SUBROUTINE conf_dat3d( title, lons,lats,levs,xd,yd,zd,xf,yf,zf, + , champd , interbar ) +c +c Auteur : P. Le Van +c +c Ce s-pr. configure le champ de donnees 3D 'champd' de telle facon +c qu'on ait - pi a pi en longitude +c qu'on ait pi/2. a - pi/2. en latitude +c et qu'on ait les niveaux verticaux variant du sol vers le ht de l'atmos. +c ( en Pascals ) . +c +c xd et yd sont les longitudes et latitudes initiales +c zd les pressions initiales +c +c xf et yf sont les longitudes et latitudes en sortie , eventuellement +c modifiees pour etre configurees comme ci-dessus . +c zf les pressions en sortie +c +c champd en meme temps le champ initial et final +c +c interbar = .TRUE. si on appelle l'interpo. barycentrique inter_barxy +c sinon , l'interpolation grille_m ( grid_atob ) . +c + + IMPLICIT NONE + +c *** Arguments en entree *** + CHARACTER*(*) :: title + INTEGER lons, lats, levs + REAL xd(lons), yd(lats), zd(levs) + LOGICAL interbar +c +c *** Arguments en sortie *** + REAL xf(lons), yf(lats), zf(levs) + +c *** Arguments en entree et sortie *** + REAL champd(lons,lats,levs) + +c *** Variables locales *** +c + REAL pi,pis2,depi,presmax + LOGICAL radianlon, invlon ,radianlat, invlat, invlev, alloc + REAL rlatmin,rlatmax,oldxd1 + INTEGER i,j,ip180,ind,l + + REAL, ALLOCATABLE :: xtemp(:) + REAL, ALLOCATABLE :: ytemp(:) + REAL, ALLOCATABLE :: ztemp(:) + REAL, ALLOCATABLE :: champf(:,:,:) + + +c WRITE(6,*) ' Conf_dat3d pour ',title + + ALLOCATE(xtemp(lons)) + ALLOCATE(ytemp(lats)) + ALLOCATE(ztemp(levs)) + + DO i = 1, lons + xtemp(i) = xd(i) + ENDDO + DO j = 1, lats + ytemp(j) = yd(j) + ENDDO + DO l = 1, levs + ztemp(l) = zd(l) + ENDDO + + pi = 2. * ASIN(1.) + pis2 = pi/2. + depi = 2. * pi + + IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN + radianlon = .TRUE. + invlon = .FALSE. + ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN + radianlon = .TRUE. + invlon = .TRUE. + ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN + radianlon = .FALSE. + invlon = .FALSE. + ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN + radianlon = .FALSE. + invlon = .TRUE. + ELSE + WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' + , , title + ENDIF + + invlat = .FALSE. + + IF( ytemp(1).LT.ytemp(lats) ) THEN + invlat = .TRUE. + ENDIF + + rlatmin = MIN( ytemp(1), ytemp(lats) ) + rlatmax = MAX( ytemp(1), ytemp(lats) ) + + IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN + radianlat = .TRUE. + ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN + radianlat = .FALSE. + ELSE + WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' + , , title + ENDIF + + IF( .NOT. radianlon ) THEN + DO i = 1, lons + xtemp(i) = xtemp(i) * pi/180. + ENDDO + ENDIF + + IF( .NOT. radianlat ) THEN + DO j = 1, lats + ytemp(j) = ytemp(j) * pi/180. + ENDDO + ENDIF + + + alloc =.FALSE. + + IF ( invlon ) THEN + + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + + DO i = 1 ,lons + xf(i) = xtemp(i) + ENDDO + + DO l = 1, levs + DO j = 1, lats + DO i= 1, lons + champf (i,j,l) = champd (i,j,l) + ENDDO + ENDDO + ENDDO +c +c *** On tourne les longit. pour avoir - pi a + pi **** +c + DO i=1,lons + IF( xf(i).GT. pi ) THEN + GO TO 88 + ENDIF + ENDDO + +88 CONTINUE +c + ip180 = i + + DO i = 1,lons + IF (xf(i).GT. pi) THEN + xf(i) = xf(i) - depi + ENDIF + ENDDO + + DO i= ip180,lons + ind = i-ip180 +1 + xtemp(ind) = xf(i) + ENDDO + + DO i= ind +1,lons + xtemp(i) = xf(i-ind) + ENDDO + +c ..... on tourne les longitudes pour champf .... +c + DO l = 1,levs + DO j = 1,lats + DO i = ip180,lons + ind = i-ip180 +1 + champd (ind,j,l) = champf (i,j,l) + ENDDO + + DO i= ind +1,lons + champd (i,j,l) = champf (i-ind,j,l) + ENDDO + ENDDO + ENDDO + + ENDIF +c +c ***** fin de IF(invlon) **** + + IF ( invlat ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + + DO j = 1, lats + ytemp( lats-j+1 ) = yf(j) + DO i = 1, lons + champd (i,lats-j+1,l) = champf (i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + +c ***** fin de IF(invlat) **** +c +c + IF( interbar ) THEN + oldxd1 = xtemp(1) + DO i = 1, lons -1 + xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) + ENDDO + xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) + + DO j = 1, lats -1 + ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) + ENDDO + ENDIF +c + + invlev = .FALSE. + IF( ztemp(1).LT.ztemp(levs) ) invlev = .TRUE. + + presmax = MAX( ztemp(1), ztemp(levs) ) + IF( presmax.LT.1200. ) THEN + DO l = 1,levs + ztemp(l) = ztemp(l) * 100. + ENDDO + ENDIF + + IF( invlev ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO l = 1,levs + zf(l) = ztemp(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + ENDDO + + DO l = 1,levs + ztemp(levs+1-l) = zf(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champd(i,j,levs+1-l) = champf(i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + + IF(alloc) DEALLOCATE(champf) + + DO i = 1, lons + xf(i) = xtemp(i) + ENDDO + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + DO l = 1, levs + zf(l) = ztemp(l) + ENDDO + + DEALLOCATE(xtemp) + DEALLOCATE(ytemp) + DEALLOCATE(ztemp) + + RETURN + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/ini_archive.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/ini_archive.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/ini_archive.F (revision 1540) @@ -0,0 +1,353 @@ +c======================================================================= + subroutine ini_archive(nid,phis,tab_cntrl_dyn,tab_cntrl_fi) +c======================================================================= +c +c +c Date: 01/1997 +c ---- +c +c Objet: ecriture de l'entete du fichier "start_archive" +c ----- +c +c Proche de iniwrite.F +c +c Arguments: +c --------- +c +c Inputs: +c ------ +c +c nid unite logique du fichier "start_archive" +c phis geopotentiel au sol +c tab_cntrl_dyn tableau des param dynamiques +c tab_cntrl_fi tableau des param physiques +c + +c======================================================================= + + USE control_mod + USE comconst_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "description.h" +#include "netcdf.inc" + +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + +c Local: +c ------ + INTEGER length,l + parameter (length = 100) + REAL tab_cntrl(2*length) ! tableau des parametres du run + INTEGER loop + INTEGER ierr, setvdim, putvdim, putdat, setname,cluvdb + INTEGER setdim + INTEGER ind1,indlast + +c Arguments: +c ---------- + REAL phis(ip1jmp1) + REAL tab_cntrl_dyn(length) + REAL tab_cntrl_fi(length) + +!Mars --------Ajouts----------- +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_llmp1,idim_llm + INTEGER idim_tim + INTEGER nid,nvarid + real sig_s(llm),s(llm) + + pi = 2. * ASIN(1.) + + +c----------------------------------------------------------------------- +c Remplissage du tableau des parametres de controle du RUN +c----------------------------------------------------------------------- + + DO l=1,length + tab_cntrl(l) = tab_cntrl_dyn(l) + tab_cntrl(length+l)= tab_cntrl_fi(l) + ENDDO + +c======================================================================= +c Ecriture NetCDF de l''entete du fichier "start_archive" +c======================================================================= + +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier start_archive") +c +c Definir les dimensions du fichiers: +c +c CHAMPS AJOUTES POUR LA VISUALISATION T,ps, etc... avec Grads ou ferret: + ierr = NF_DEF_DIM (nid,"index", 2*length, idim_index) + ierr = NF_DEF_DIM (nid,"rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid,"rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid,"rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid,"rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid,"sigs", llm, idim_llm) + ierr = NF_DEF_DIM (nid,"sig", llmp1, idim_llmp1) + ierr = NF_DEF_DIM (nid,"Time", NF_UNLIMITED, idim_tim) + +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + +c----------------------------------------------------------------------- +c Ecriture du tableau des parametres du run +c----------------------------------------------------------------------- + + call def_var(nid,"Time","Time","days since 00:00:00",1, + . idim_tim,nvarid,ierr) + + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,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----------------------------------------------------------------------- +c Ecriture des longitudes et latitudes +c----------------------------------------------------------------------- + + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif + +c----------------------------------------------------------------------- +c Ecriture des niveaux verticaux +c----------------------------------------------------------------------- + + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_llm,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_llm,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_llmp1,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_llmp1,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_llmp1,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_llmp1,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Coef A: niveaux pression hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_llmp1,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_llmp1,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 35, + . "Coefficient B niveaux sigma hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c +c ---------------------- + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_llm,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_llm,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif + +c----------------------------------------------------------------------- +c Ecriture aire et coefficients de passage cov. <-> contra. <--> naturel +c----------------------------------------------------------------------- + + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif + +c----------------------------------------------------------------------- +c Ecriture du geopentiel au sol +c----------------------------------------------------------------------- + + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif + + RETURN + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/iniphysiq_mod.F90 =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/iniphysiq_mod.F90 (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/iniphysiq_mod.F90 (revision 1540) @@ -0,0 +1,238 @@ +! +! $Id: iniphysiq.F90 2225 2015-03-11 14:55:23Z emillour $ +! +MODULE iniphysiq_mod + +CONTAINS + +SUBROUTINE iniphysiq(iim,jjm,nlayer,punjours, pdayref,ptimestep, & + rlatu,rlatv,rlonu,rlonv,aire,cu,cv, & + prad,pg,pr,pcpp,iflag_phys) + USE dimphy, ONLY: klev ! number of atmospheric levels + USE mod_grid_phy_lmdz, ONLY: klon_glo ! number of atmospheric columns + ! (on full grid) + USE mod_phys_lmdz_para, ONLY: klon_omp, & ! number of columns (on local omp grid) + klon_omp_begin, & ! start index of local omp subgrid + klon_omp_end, & ! end index of local omp subgrid + klon_mpi_begin ! start indes of columns (on local mpi grid) + USE control_mod, ONLY: nday + USE comgeomphy, ONLY: initcomgeomphy, & + airephy, & ! physics grid area (m2) + cuphy, & ! cu coeff. (u_covariant = cu * u) + cvphy, & ! cv coeff. (v_covariant = cv * v) + rlond, & ! longitudes + rlatd ! latitudes + USE temps_mod, ONLY: annee_ref, day_ref, day_ini, day_end + USE time_phylmdz_mod, ONLY: init_time + USE regular_lonlat_mod, ONLY : init_regular_lonlat, & + east, west, north, south, & + north_east, north_west, & + south_west, south_east + USE nrtype, ONLY: pi + IMPLICIT NONE + + ! ======================================================================= + ! Initialisation of the physical constants and some positional and + ! geometrical arrays for the physics + ! ======================================================================= + + include "YOMCST.h" + include "iniprint.h" + + REAL, INTENT (IN) :: prad ! radius of the planet (m) + REAL, INTENT (IN) :: pg ! gravitational acceleration (m/s2) + REAL, INTENT (IN) :: pr ! ! reduced gas constant R/mu + REAL, INTENT (IN) :: pcpp ! specific heat Cp + REAL, INTENT (IN) :: punjours ! length (in s) of a standard day + INTEGER, INTENT (IN) :: nlayer ! number of atmospheric layers + INTEGER, INTENT (IN) :: iim ! number of atmospheric columns along longitudes + INTEGER, INTENT (IN) :: jjm ! number of atompsheric columns along latitudes + REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid + REAL, INTENT (IN) :: rlatv(jjm) ! latitude boundaries of the physics grid + REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes of the physics grid + REAL, INTENT (IN) :: rlonu(iim+1) ! longitude boundaries of the physics grid + REAL, INTENT (IN) :: aire(iim+1,jjm+1) ! area of the dynamics grid (m2) + REAL, INTENT (IN) :: cu((iim+1)*(jjm+1)) ! cu coeff. (u_covariant = cu * u) + REAL, INTENT (IN) :: cv((iim+1)*jjm) ! cv coeff. (v_covariant = cv * v) + INTEGER, INTENT (IN) :: pdayref ! reference day of for the simulation + REAL, INTENT (IN) :: ptimestep !physics time step (s) + INTEGER, INTENT (IN) :: iflag_phys ! type of physics to be called + + INTEGER :: ibegin, iend, offset + INTEGER :: i,j + CHARACTER (LEN=20) :: modname = 'iniphysiq' + CHARACTER (LEN=80) :: abort_message + REAL :: total_area_phy, total_area_dyn + + ! boundaries, on global grid + REAL,ALLOCATABLE :: boundslon_reg(:,:) + REAL,ALLOCATABLE :: boundslat_reg(:,:) + + ! global array, on full physics grid: + REAL,ALLOCATABLE :: latfi(:) + REAL,ALLOCATABLE :: lonfi(:) + REAL,ALLOCATABLE :: cufi(:) + REAL,ALLOCATABLE :: cvfi(:) + REAL,ALLOCATABLE :: airefi(:) + + IF (nlayer/=klev) THEN + WRITE (lunout, *) 'STOP in ', trim(modname) + WRITE (lunout, *) 'Problem with dimensions :' + WRITE (lunout, *) 'nlayer = ', nlayer + WRITE (lunout, *) 'klev = ', klev + abort_message = '' + CALL abort_gcm(modname, 'Problem with dimensions', 1) + END IF + + !call init_phys_lmdz(iim,jjm+1,llm,1,(/(jjm-1)*iim+2/)) + + ! init regular global longitude-latitude grid points and boundaries + ALLOCATE(boundslon_reg(iim,2)) + ALLOCATE(boundslat_reg(jjm+1,2)) + + DO i=1,iim + boundslon_reg(i,east)=rlonu(i) + boundslon_reg(i,west)=rlonu(i+1) + ENDDO + + boundslat_reg(1,north)= PI/2 + boundslat_reg(1,south)= rlatv(1) + DO j=2,jjm + boundslat_reg(j,north)=rlatv(j-1) + boundslat_reg(j,south)=rlatv(j) + ENDDO + boundslat_reg(jjm+1,north)= rlatv(jjm) + boundslat_reg(jjm+1,south)= -PI/2 + + ! Write values in module regular_lonlat_mod + CALL init_regular_lonlat(iim,jjm+1, rlonv(1:iim), rlatu, & + boundslon_reg, boundslat_reg) + + ! Generate global arrays on full physics grid + ALLOCATE(latfi(klon_glo),lonfi(klon_glo),cufi(klon_glo),cvfi(klon_glo)) + ALLOCATE(airefi(klon_glo)) + + IF (klon_glo>1) THEN ! general case + ! North pole + latfi(1)=rlatu(1) + lonfi(1)=0. + cufi(1) = cu(1) + cvfi(1) = cv(1) + DO j=2,jjm + DO i=1,iim + latfi((j-2)*iim+1+i)= rlatu(j) + lonfi((j-2)*iim+1+i)= rlonv(i) + cufi((j-2)*iim+1+i) = cu((j-1)*(iim+1)+i) + cvfi((j-2)*iim+1+i) = cv((j-1)*(iim+1)+i) + ENDDO + ENDDO + ! South pole + latfi(klon_glo)= rlatu(jjm+1) + lonfi(klon_glo)= 0. + cufi(klon_glo) = cu((iim+1)*jjm+1) + cvfi(klon_glo) = cv((iim+1)*jjm-iim) + + ! build airefi(), mesh area on physics grid + CALL gr_dyn_fi(1,iim+1,jjm+1,klon_glo,aire,airefi) + ! Poles are single points on physics grid + airefi(1)=sum(aire(1:iim,1)) + airefi(klon_glo)=sum(aire(1:iim,jjm+1)) + + ! Sanity check: do total planet area match between physics and dynamics? + total_area_dyn=sum(aire(1:iim,1:jjm+1)) + total_area_phy=sum(airefi(1:klon_glo)) + IF (total_area_dyn/=total_area_phy) THEN + WRITE (lunout, *) 'iniphysiq: planet total surface discrepancy !!!' + WRITE (lunout, *) ' in the dynamics total_area_dyn=', total_area_dyn + WRITE (lunout, *) ' but in the physics total_area_phy=', total_area_phy + IF (abs(total_area_dyn-total_area_phy)>0.00001*total_area_dyn) THEN + ! stop here if the relative difference is more than 0.001% + abort_message = 'planet total surface discrepancy' + CALL abort_gcm(modname, abort_message, 1) + ENDIF + ENDIF + ELSE ! klon_glo==1, running the 1D model + ! just copy over input values + latfi(1)=rlatu(1) + lonfi(1)=rlonv(1) + cufi(1)=cu(1) + cvfi(1)=cv(1) + airefi(1)=aire(1,1) + ENDIF ! of IF (klon_glo>1) + +!$OMP PARALLEL + ! Now generate local lon/lat/cu/cv/area arrays + CALL initcomgeomphy + + offset = klon_mpi_begin - 1 + airephy(1:klon_omp) = airefi(offset+klon_omp_begin:offset+klon_omp_end) + cuphy(1:klon_omp) = cufi(offset+klon_omp_begin:offset+klon_omp_end) + cvphy(1:klon_omp) = cvfi(offset+klon_omp_begin:offset+klon_omp_end) + rlond(1:klon_omp) = lonfi(offset+klon_omp_begin:offset+klon_omp_end) + rlatd(1:klon_omp) = latfi(offset+klon_omp_begin:offset+klon_omp_end) + + ! Initialize some physical constants + call suphec + + ! Initialize some "temporal and calendar" related variables + CALL init_time(annee_ref,day_ref,day_ini,day_end,nday,ptimestep) + +!$OMP END PARALLEL + + ! check that physical constants set in 'suphec' are coherent + ! with values set in the dynamics: + IF (rday/=punjours) THEN + WRITE (lunout, *) 'iniphysiq: length of day discrepancy!!!' + WRITE (lunout, *) ' in the dynamics punjours=', punjours + WRITE (lunout, *) ' but in the physics RDAY=', rday + IF (abs(rday-punjours)>0.01*punjours) THEN + ! stop here if the relative difference is more than 1% + abort_message = 'length of day discrepancy' + CALL abort_gcm(modname, abort_message, 1) + END IF + END IF + + IF (rg/=pg) THEN + WRITE (lunout, *) 'iniphysiq: gravity discrepancy !!!' + WRITE (lunout, *) ' in the dynamics pg=', pg + WRITE (lunout, *) ' but in the physics RG=', rg + IF (abs(rg-pg)>0.01*pg) THEN + ! stop here if the relative difference is more than 1% + abort_message = 'gravity discrepancy' + CALL abort_gcm(modname, abort_message, 1) + END IF + END IF + IF (ra/=prad) THEN + WRITE (lunout, *) 'iniphysiq: planet radius discrepancy !!!' + WRITE (lunout, *) ' in the dynamics prad=', prad + WRITE (lunout, *) ' but in the physics RA=', ra + IF (abs(ra-prad)>0.01*prad) THEN + ! stop here if the relative difference is more than 1% + abort_message = 'planet radius discrepancy' + CALL abort_gcm(modname, abort_message, 1) + END IF + END IF + IF (rd/=pr) THEN + WRITE (lunout, *) 'iniphysiq: reduced gas constant discrepancy !!!' + WRITE (lunout, *) ' in the dynamics pr=', pr + WRITE (lunout, *) ' but in the physics RD=', rd + IF (abs(rd-pr)>0.01*pr) THEN + ! stop here if the relative difference is more than 1% + abort_message = 'reduced gas constant discrepancy' + CALL abort_gcm(modname, abort_message, 1) + END IF + END IF + IF (rcpd/=pcpp) THEN + WRITE (lunout, *) 'iniphysiq: specific heat discrepancy !!!' + WRITE (lunout, *) ' in the dynamics pcpp=', pcpp + WRITE (lunout, *) ' but in the physics RCPD=', rcpd + IF (abs(rcpd-pcpp)>0.01*pcpp) THEN + ! stop here if the relative difference is more than 1% + abort_message = 'specific heat discrepancy' + CALL abort_gcm(modname, abort_message, 1) + END IF + END IF + +END SUBROUTINE iniphysiq + +END MODULE iniphysiq_mod Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/newstart.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/newstart.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/newstart.F (revision 1540) @@ -0,0 +1,1144 @@ +C====================================================================== + PROGRAM newstart +c======================================================================= +c +c +c Auteur: S. Lebonnois, +c a partir des newstart/start_archive/lect_start_archive martiens +c +c Derniere modif : 02/09 (ecriture des q*) +c 01/12 (inclusion dans svn dyn3d) +c +c Objet: Modify the grid for the initial state (LMD GCM VENUS/TITAN) +c ----- (from file NetCDF start_archive.nc) +c +c +c======================================================================= + + use IOIPSL + USE filtreg_mod + USE startvar + USE control_mod + USE infotrac + use cpdet_mod, only: ini_cpdet,t2tpot + use exner_hyb_m, only: exner_hyb + use exner_milieu_m, only: exner_milieu + USE comconst_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + USE serre_mod, ONLY: clon,clat,grossismx,grossismy, + & dzoomx,dzoomy,taux,tauy + USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0 + USE logic_mod, ONLY: iflag_trac,fxyhypb,ysinus + USE temps_mod, ONLY: day_ref,annee_ref + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comdissnew.h" +#include "comgeom2.h" +#include "description.h" +#include "dimsoil.h" +#include "netcdf.inc" + +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + +c Variables pour fichier "ini" +c------------------------------------ + INTEGER imold,jmold,lmold,nqold,ip1jmp1old + INTEGER length + parameter (length = 100) + real tab_cntrl(2*length) + INTEGER isoil,iq,iqmax + CHARACTER*2 str2 + +c Variable histoire +c------------------ + REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants + REAL teta(iip1,jjp1,llm),ps(iip1,jjp1) + REAL phis(iip1,jjp1) ! geopotentiel au sol + REAL masse(ip1jmp1,llm) ! masse de l'atmosphere + REAL, ALLOCATABLE, DIMENSION(:,:,:,:):: q! champs advectes + REAL tab_cntrl_dyn(length) ! tableau des parametres de start + +c variable physique +c------------------ + integer ngridmx + parameter (ngridmx=(2+(jjm-1)*iim - 1/jjm)) + REAL tab_cntrl_fi(length) ! tableau des parametres de startfi + real rlat(ngridmx),rlon(ngridmx) + REAL tsurf(ngridmx),tsoil(ngridmx,nsoilmx) + REAL albe(ngridmx),radsol(ngridmx),sollw(ngridmx) + real solsw(ngridmx),dlw(ngridmx) + REAL zmea(ngridmx), zstd(ngridmx) + REAL zsig(ngridmx), zgam(ngridmx), zthe(ngridmx) + REAL zpic(ngridmx), zval(ngridmx) + real t_fi(ngridmx,llm) + +c Variable nouvelle grille naturelle au point scalaire +c------------------------------------------------------ + real us(iip1,jjp1,llm),vs(iip1,jjp1,llm) + REAL p3d(iip1,jjp1,llm+1) ! pression aux interfaces + REAL phisold_newgrid(iip1,jjp1) + REAL T(iip1,jjp1,llm) + real rlonS(iip1,jjp1),rlatS(iip1,jjp1) + real tsurfS(iip1,jjp1),tsoilS(iip1,jjp1,nsoilmx) + real albeS(ip1jmp1),radsolS(ip1jmp1),sollwS(ip1jmp1) + real solswS(ip1jmp1),dlwS(ip1jmp1) + real zmeaS(ip1jmp1),zstdS(ip1jmp1),zsigS(ip1jmp1) + real zgamS(ip1jmp1),ztheS(ip1jmp1),zpicS(ip1jmp1) + real zvalS(ip1jmp1) + + real ptotal + +c Var intermediaires : vent naturel, mais pas coord scalaire +c----------------------------------------------------------- + real vnat(iip1,jjm,llm),unat(iip1,jjp1,llm) + + REAL pks(iip1,jjp1) ! exner (f pour filtre) + REAL pk(iip1,jjp1,llm) + REAL pkf(iip1,jjp1,llm) + REAL alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm) + + +c Variable de l'ancienne grille +c--------------------------------------------------------- + + real, dimension(:), allocatable :: rlonuold, rlatvold + real, dimension(:), allocatable :: rlonvold, rlatuold + real, dimension(:), allocatable :: nivsigsold,nivsigold + real, dimension(:), allocatable :: apold,bpold + real, dimension(:), allocatable :: presnivsold + real, dimension(:,:,:), allocatable :: uold,vold,told + real, dimension(:,:,:,:), allocatable :: qold + real, dimension(:,:,:), allocatable :: tsoilold + real, dimension(:,:), allocatable :: psold,phisold + real, dimension(:,:), allocatable :: tsurfold + real, dimension(:,:), allocatable :: albeold,radsolold + real, dimension(:,:), allocatable :: sollwold,solswold + real, dimension(:,:), allocatable :: dlwold + real, dimension(:,:), allocatable :: zmeaold,zstdold,zsigold + real, dimension(:,:), allocatable :: zgamold,ztheold,zpicold + real, dimension(:,:), allocatable :: zvalold + + real ptotalold + +c Variable intermediaires iutilise pour l'extrapolation verticale +c---------------------------------------------------------------- + real, dimension(:,:,:), allocatable :: var,varp1 + +c divers local +c----------------- + + integer ierr,nid,nvarid + INTEGER ij, l,i,j + character*80 fichnom + integer, dimension(4) :: start,counter + REAL phisinverse(iip1,jjp1) ! geopotentiel au sol avant inversion + logical topoflag,albedoflag,razvitu,razvitv + real albedo + +c======================================================================= +c INITIALISATIONS DIVERSES +c======================================================================= + +c VENUS/TITAN + + iflag_trac = 1 +c----------------------------------------------------------------------- +c Initialisation des traceurs +c --------------------------- +c Choix du nombre de traceurs et du schema pour l'advection +c dans fichier traceur.def, par default ou via INCA + call infotrac_init + +c Allocation de la tableau q : champs advectes + allocate(q(iip1,jjp1,llm,nqtot)) + +c----------------------------------------------------------------------- +c Ouverture du fichier a modifier (start_archive.nc) +c----------------------------------------------------------------------- + + write(*,*) 'Creation d un etat initial a partir de' + write(*,*) './start_archive.nc' + write(*,*) + fichnom = 'start_archive.nc' + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier ',fichnom + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + +c----------------------------------------------------------------------- +c Lecture du tableau des parametres du run (pour la dynamique) +c----------------------------------------------------------------------- + + write(*,*) 'lecture tab_cntrl START_ARCHIVE' +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif +c + write(*,*) 'Impression de tab_cntrl' + do i=1,200 + write(*,*) i,tab_cntrl(i) + enddo + +c----------------------------------------------------------------------- +c Initialisation des constantes +c----------------------------------------------------------------------- + + imold = tab_cntrl(1) + jmold = tab_cntrl(2) + lmold = tab_cntrl(3) + day_ref = tab_cntrl(4) + annee_ref = tab_cntrl(5) + rad = tab_cntrl(6) + omeg = tab_cntrl(7) + g = tab_cntrl(8) + cpp = tab_cntrl(9) + kappa = tab_cntrl(10) + daysec = tab_cntrl(11) + dtvr = tab_cntrl(12) + etot0 = tab_cntrl(13) + ptot0 = tab_cntrl(14) + ztot0 = tab_cntrl(15) + stot0 = tab_cntrl(16) + ang0 = tab_cntrl(17) + pa = tab_cntrl(18) + preff = tab_cntrl(19) +c + clon = tab_cntrl(20) + clat = tab_cntrl(21) + grossismx = tab_cntrl(22) + grossismy = tab_cntrl(23) + + IF ( tab_cntrl(24).EQ.1. ) THEN + fxyhypb = . TRUE . + dzoomx = tab_cntrl(25) + dzoomy = tab_cntrl(26) + taux = tab_cntrl(28) + tauy = tab_cntrl(29) + ELSE + fxyhypb = . FALSE . + ysinus = . FALSE . + IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. + ENDIF + + ptotalold = tab_cntrl(2*length) + + write(*,*) "Old dimensions:" + write(*,*) "longitude: ",imold + write(*,*) "latitude: ",jmold + write(*,*) "altitude: ",lmold + write(*,*) + + ip1jmp1old = (imold+1-1/imold)*(jmold+1-1/jmold) + +c dans run.def + CALL getin('planet_type',planet_type) + call ini_cpdet + +c======================================================================= +c CHANGEMENT DE CONSTANTES CONTENUES DANS tab_cntrl +c======================================================================= +c changement de la resolution dans le fichier de controle + tab_cntrl(1) = REAL(iim) + tab_cntrl(2) = REAL(jjm) + tab_cntrl(3) = REAL(llm) + +c-------------------------------- +c We use a specific run.def to read new parameters that need to be changed +c-------------------------------- + +c Changement de cpp: + CALL getin('cpp',cpp) + kappa = (8.314511/43.44E-3)/cpp + tab_cntrl(9) = cpp + tab_cntrl(10) = kappa + +c CHANGING THE ZOOM PARAMETERS TO CHANGE THE GRID + CALL getin('clon',clon) + CALL getin('clat',clat) + tab_cntrl(20) = clon + tab_cntrl(21) = clat + CALL getin('grossismx',grossismx) + CALL getin('grossismy',grossismy) + tab_cntrl(22) = grossismx + tab_cntrl(23) = grossismy + CALL getin('fxyhypb',fxyhypb) + IF ( fxyhypb ) THEN + CALL getin('dzoomx',dzoomx) + CALL getin('dzoomy',dzoomy) + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + CALL getin('taux',taux) + CALL getin('tauy',tauy) + tab_cntrl(28) = taux + tab_cntrl(29) = tauy + ELSE + CALL getin('ysinus',ysinus) + IF (ysinus) THEN + tab_cntrl(27) = 1 + ELSE + tab_cntrl(27) = 0 + ENDIF + ENDIF + +c changes must be done BEFORE these lines... + DO l=1,length + tab_cntrl_dyn(l)= tab_cntrl(l) + tab_cntrl_fi(l) = tab_cntrl(l+length) + ENDDO + +c----------------------------------------------------------------------- +c Autres initialisations +c----------------------------------------------------------------------- + + CALL iniconst + CALL inigeom + call inifilr + +c----------------------------------------------------------------------- +c Allocations des anciennes variables +c----------------------------------------------------------------------- + + allocate(rlonuold(imold+1), rlatvold(jmold)) + allocate(rlonvold(imold+1), rlatuold(jmold+1)) + allocate(nivsigsold(lmold+1),nivsigold(lmold)) + allocate(apold(lmold),bpold(lmold)) + allocate(presnivsold(lmold)) + allocate(uold(imold+1,jmold+1,lmold)) + allocate(vold(imold+1,jmold+1,lmold)) + allocate(told(imold+1,jmold+1,lmold)) + allocate(qold(imold+1,jmold+1,lmold,nqtot)) + allocate(psold(imold+1,jmold+1)) + allocate(phisold(imold+1,jmold+1)) + allocate(tsurfold(imold+1,jmold+1)) + allocate(tsoilold(imold+1,jmold+1,nsoilmx)) + allocate(albeold(imold+1,jmold+1),radsolold(imold+1,jmold+1)) + allocate(sollwold(imold+1,jmold+1),solswold(imold+1,jmold+1)) + allocate(dlwold(imold+1,jmold+1)) + allocate(zmeaold(imold+1,jmold+1),zstdold(imold+1,jmold+1)) + allocate(zsigold(imold+1,jmold+1),zgamold(imold+1,jmold+1)) + allocate(ztheold(imold+1,jmold+1),zpicold(imold+1,jmold+1)) + allocate(zvalold(imold+1,jmold+1)) + + allocate(var (imold+1,jmold+1,llm)) + allocate(varp1 (imold+1,jmold+1,llm+1)) + + print*,"Initialisations OK" + +c----------------------------------------------------------------------- +c Lecture des longitudes et latitudes +c----------------------------------------------------------------------- +c + ierr = NF_INQ_VARID (nid, "rlonv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonvold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonvold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "rlatu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatuold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatuold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "rlonu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonuold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonuold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "rlatv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatvold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatvold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + ENDIF +c + + print*,"Lecture lon/lat OK" + +c----------------------------------------------------------------------- +c Lecture des niveaux verticaux +c----------------------------------------------------------------------- +c + ierr = NF_INQ_VARID (nid, "nivsigs", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, nivsigsold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, nivsigsold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "nivsig", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, nivsigold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, nivsigold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ap", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, apold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, apold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + ENDIF + ENDIF +c + ierr = NF_INQ_VARID (nid, "bp", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, bpold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, bpold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + END IF + + ierr = NF_INQ_VARID (nid, "presnivs", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, presnivsold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, presnivsold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + +c----------------------------------------------------------------------- +c Lecture geopotentiel au sol +c----------------------------------------------------------------------- +c + ierr = NF_INQ_VARID (nid, "phisinit", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phisold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, phisold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + ENDIF + + print*,"Lecture niveaux et geopot OK" + +c----------------------------------------------------------------------- +c Lecture des champs 2D () +c----------------------------------------------------------------------- + + start=(/1,1,1,0/) + counter=(/imold+1,jmold+1,1,0/) + + ierr = NF_INQ_VARID (nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,psold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,psold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "tsurf", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,tsurfold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,tsurfold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + do isoil=1,nsoilmx + write(str2,'(i2.2)') isoil +c + ierr = NF_INQ_VARID (nid, "Tsoil"//str2, nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: + . Le champ <","Tsoil"//str2,"> est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter, + . tsoilold(1,1,isoil)) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter, + . tsoilold(1,1,isoil)) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: + . Lecture echouee pour <","Tsoil"//str2,">" + CALL abort + ENDIF + end do +c + ierr = NF_INQ_VARID (nid, "albe", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,albeold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,albeold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "radsol", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,radsolold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,radsolold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "sollw", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,sollwold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,sollwold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "solsw", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,solswold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,solswold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "dlw", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,dlwold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,dlwold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zmea", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zmeaold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zmeaold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zmeaold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zstd", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zstdold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zstdold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zstdold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zsig", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zsigold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zsigold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zsigold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zgam", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zgamold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zgamold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zgamold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zthe", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + ztheold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,ztheold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,ztheold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zpic", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zpicold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zpicold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zpicold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zval", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zvalold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zvalold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zvalold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + + print*,"Lecture champs 2D OK" + +c----------------------------------------------------------------------- +c Lecture des champs 3D () +c----------------------------------------------------------------------- + + start=(/1,1,1,1/) + counter=(/imold+1,jmold+1,lmold,1/) +c + ierr = NF_INQ_VARID (nid,"temp", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid, start, counter, told) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid, start, counter, told) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid,"u", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,uold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,uold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid,"v", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,vold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,vold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + +c TNAME: IL EST LU A PARTIR DE traceur.def (mettre l'ancien si +c changement du nombre de traceurs) + + IF(iflag_trac.eq.1) THEN + DO iq=1,nqtot + ierr = NF_INQ_VARID (nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent" + PRINT*, " Il est donc initialise a zero" + qold(:,:,:,iq)=0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,counter,qold(1,1,1,iq)) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,qold(1,1,1,iq)) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour "//tname(iq) + CALL abort + ENDIF + ENDIF + ENDDO + ENDIF + + + print*,"Lecture champs 3D OK" + +c======================================================================= +c INTERPOLATION DANS LA NOUVELLE GRILLE et initialisation des variables +c======================================================================= +c Interpolation horizontale puis passage dans la grille physique pour +c les variables physique +c Interpolation verticale puis horizontale pour chaque variable 3D +c======================================================================= + +c----------------------------------------------------------------------- +c Variable 2d : +c----------------------------------------------------------------------- + +c Relief +! topoflag = F: we keep the existing topography +! = T: we read it from the Relief.nc file +! topoflag need to be in the specific run.def for newstart + topoflag = . FALSE . + CALL getin('topoflag',topoflag) + + IF ( topoflag ) then + print*,"Topography (phis) read in file Relief.nc" + print*,"For Venus, map directly inverted in Relief.nc" + CALL startget_phys2d('surfgeo',iip1,jjp1,rlonv,rlatu,phis,0.0, + . jjm ,rlonu,rlatv,.true.) +c needed ? + phis(iip1,:) = phis(1,:) + + CALL startget_phys1d('zmea',iip1,jjp1,rlonv,rlatu,ngridmx,zmea, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zstd',iip1,jjp1,rlonv,rlatu,ngridmx,zstd, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zsig',iip1,jjp1,rlonv,rlatu,ngridmx,zsig, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zgam',iip1,jjp1,rlonv,rlatu,ngridmx,zgam, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zthe',iip1,jjp1,rlonv,rlatu,ngridmx,zthe, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zpic',iip1,jjp1,rlonv,rlatu,ngridmx,zpic, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zval',iip1,jjp1,rlonv,rlatu,ngridmx,zval, + . 0.0,jjm,rlonu,rlatv,.true.) + + ELSE + print*,'Using existing topography' + call interp_horiz (phisold,phis,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + + call interp_horiz (zmeaold,zmeaS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zmeaS,zmea) + call interp_horiz (zstdold,zstdS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zstdS,zstd) + call interp_horiz (zsigold,zsigS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zsigS,zsig) + call interp_horiz (zgamold,zgamS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zgamS,zgam) + call interp_horiz (ztheold,ztheS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,ztheS,zthe) + call interp_horiz (zpicold,zpicS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zpicS,zpic) + call interp_horiz (zvalold,zvalS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zvalS,zval) + ENDIF + + print*,"New surface geopotential OK" + +c Lat et lon pour physique + do i=1,iip1 + rlatS(i,:)=rlatu(:)*180./pi + enddo + call gr_dyn_fi (1,iip1,jjp1,ngridmx,rlatS,rlat) + + do j=2,jjm + rlonS(:,j)=rlonv(:)*180./pi + enddo + rlonS(:,1)=0. + rlonS(:,jjp1)=0. + call gr_dyn_fi (1,iip1,jjp1,ngridmx,rlonS,rlon) + +c Temperature de surface + call interp_horiz (tsurfold,tsurfS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,tsurfS,tsurf) +c write(44,*) 'tsurf', tsurf + +c Temperature du sous-sol + call interp_horiz(tsoilold,tsoilS, + & imold,jmold,iim,jjm,nsoilmx, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (nsoilmx,iip1,jjp1,ngridmx,tsoilS,tsoil) +c write(45,*) 'tsoil',tsoil + +! CHANGING ALBEDO: may be done through run.def + albedoflag = . FALSE . + CALL getin('albedoflag',albedoflag) + + IF ( albedoflag ) then + print*,"Albedo is reinitialized to the albedo value in run.def" + print*,"We may want to consider a map later on..." + albedo=0.1 + CALL getin('albedo',albedo) + albe=albedo + ELSE + call interp_horiz (albeold,albeS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,albeS,albe) + ENDIF + + call interp_horiz (radsolold,radsolS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,radsolS,radsol) + + call interp_horiz (sollwold,sollwS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,sollwS,sollw) + + call interp_horiz (solswold,solswS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,solswS,solsw) + + call interp_horiz (dlwold,dlwS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,dlwS,dlw) + + print*,"Nouvelles var physiques OK" + +c----------------------------------------------------------------------- +c Traitement special de la pression au sol : +c----------------------------------------------------------------------- + +c Extrapolation la pression dans la nouvelle grille + call interp_horiz(psold,ps,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + +c On assure la conservation de la masse de l'atmosphere +c-------------------------------------------------------------- + +!!! ATTENTION TEMPORAIRE +c ps(:,:)=146700. + + ptotal = 0. + DO j=1,jjp1 + DO i=1,iim + ptotal=ptotal+ps(i,j)*aire(i,j)/g + END DO + END DO + + write(*,*) + write(*,*)'Ancienne grille: masse de l atm :',ptotalold + write(*,*)'Nouvelle grille: masse de l atm :',ptotal + write (*,*) 'Ratio new atm./ old atm =', ptotal/ptotalold + write(*,*) + + + DO j=1,jjp1 + DO i=1,iip1 + ps(i,j)=ps(i,j) * ptotalold/ptotal + END DO + END DO + +c la pression de surface et les temperatures ne sont pas reequilibrees en fonction +c de la nouvelle topographie... +c Si l'ajustement inevitable du debut pose des problemes, voir le newstart martien. + + print*,"Nouvelle ps OK" + print*,"If changes done on topography, beware !" + print*,"Some time may be needed for adjustments at the beginning" + print*,"so if unstable, relax the timestep and/or dissipation." + +c----------------------------------------------------------------------- +c Variable 3d : +c----------------------------------------------------------------------- + + CALL pression(ip1jmp1, ap, bp, ps, p3d) + if (disvert_type==1) then + CALL exner_hyb( ip1jmp1, ps, p3d, pks, pk, pkf ) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu( ip1jmp1, ps, p3d, pks, pk, pkf ) + endif + +c temperatures atmospheriques + +c ATTENTION: peut servir, mais bon... +c do l=1,lmold +c do j=1,jmold+1 +c do i=1,imold+1 +c modif: profil uniforme +c told(i,j,l)=told(1,jmold/2,l) +c mean T profile: +c told(i,j,l) = 142.1*exp(-((p3d(i,j,l)/100.+21.45)/40.11)**2.) +c . + 106.3*exp(-((p3d(i,j,l)/100.-3183.)/4737.)**2.) +c enddo +c enddo +c enddo + + write (*,*) 'told ', told (1,jmold+1,1) ! INFO + call interp_vert + & (told,var,lmold,llm,apold,bpold,ap,bp, + & psold,(imold+1)*(jmold+1)) + write (*,*) 'var ', var (1,jmold+1,1) ! INFO + call interp_horiz(var,t,imold,jmold,iim,jjm,llm, + & rlonuold,rlatvold,rlonu,rlatv) + write (*,*) 'T ', T(1,jjp1,1) ! INFO +! pour info: +! Si extension verticale, la T est extrapolee constante au-dessus de lmold + +c passage grille physique pour restartphy.nc + call gr_dyn_fi (llm,iip1,jjp1,ngridmx,T,t_fi) + +! ADAPTATION GCM POUR CP(T) +c passage en temperature potentielle + call t2tpot(ip1jmp1*llm,T,teta,pk) +c on assure la periodicite + teta(iip1,:,:) = teta(1,:,:) + +! RESETING U TO 0: may be done through run.def + razvitu = . FALSE . + CALL getin('razvitu',razvitu) + razvitv = . FALSE . + CALL getin('razvitv',razvitv) + +c calcul des champ de vent; passage en vent covariant + write (*,*) 'uold ', uold (1,2,1) ! INFO + call interp_vert + & (uold,var,lmold,llm,apold,bpold,ap,bp, + & psold,(imold+1)*(jmold+1)) + write (*,*) 'var ', var (1,2,1) ! INFO + call interp_horiz(var,us,imold,jmold,iim,jjm,llm, + & rlonuold,rlatvold,rlonu,rlatv) + write (*,*) 'us ', us (1,2,1) ! INFO + + call interp_vert + & (vold,var,lmold,llm, + & apold,bpold,ap,bp,psold,(imold+1)*(jmold+1)) + call interp_horiz(var,vs,imold,jmold,iim,jjm,llm, + & rlonuold,rlatvold,rlonu,rlatv) + call scal_wind(us,vs,unat,vnat) +! Reseting u=0 + if (razvitu) then + unat(:,:,:) = 0. + endif + write (*,*) 'unat ', unat (1,2,1) ! INFO + do l=1,llm + do j = 1, jjp1 + do i=1,iip1 + ucov( i,j,l ) = unat( i,j,l ) * cu(i,j) +! pour info: +! Si extension verticale, on impose u=0 au-dessus de lmold + if (l.gt.lmold) ucov( i,j,l ) = 0 + end do + end do + end do + write (*,*) 'ucov ', ucov (1,2,1) ! INFO +c write(48,*) 'ucov',ucov +! Reseting v=0 + if (razvitv) then + vnat(:,:,:) = 0. + endif + write (*,*) 'vnat ', vnat (1,2,1) ! INFO + do l=1,llm + do j = 1, jjm + do i=1,iim + vcov( i,j,l ) = vnat( i,j,l ) * cv(i,j) +! pour info: +! Si extension verticale, on impose v=0 au-dessus de lmold + if (l.gt.lmold) vcov( i,j,l ) = 0 + end do + vcov( iip1,j,l ) = vcov( 1,j,l ) + end do + end do +c write(49,*) 'ucov',vcov + +c masse: on la recalcule (ps a été ajustée pour conserver la masse totale) + call massdair(p3d,masse) + +c traceurs 3D + do iq = 1, nqtot + call interp_vert(qold(1,1,1,iq),var,lmold,llm, + & apold,bpold,ap,bp,psold,(imold+1)*(jmold+1)) + call interp_horiz(var,q(1,1,1,iq),imold,jmold,iim,jjm,llm, + & rlonuold,rlatvold,rlonu,rlatv) + enddo + + print*,"Nouvelles var dynamiques OK" + +c======================================================================= +c Ecriture des restart.nc et restartphy.nc : +c======================================================================= + + call writerestart('restart.nc',tab_cntrl_dyn, + . phis,vcov,ucov,teta,masse,q,ps) + + print*,"restart OK" + + call writerestartphy('restartphy.nc',tab_cntrl_fi,ngridmx,llm, + . rlat,rlon,tsurf,tsoil,albe,solsw, sollw,dlw, + . radsol, + . zmea,zstd,zsig,zgam,zthe,zpic,zval, + . t_fi) + + print*,"restartphy OK" + + end Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/readstart.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/readstart.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/readstart.F (revision 1540) @@ -0,0 +1,499 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/dynetat0.F,v 1.2 2004/06/22 11:45:30 lmdzadmin Exp $ +! + SUBROUTINE readstart(fichnom,nq,vcov,ucov, + . teta,q,masse,ps,phis,tab_cntrl) + + USE infotrac + USE comconst_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + USE serre_mod, ONLY: clon,clat,grossismx,grossismy + USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0 + USE temps_mod, ONLY: day_ref,annee_ref,day_ini,itau_dyn, + & start_time + USE logic_mod, ONLY: fxyhypb,ysinus,iflag_trac + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van / L.Fairhead +c ------- +c +c objet: +c ------ +c +c Lecture de l'etat initial +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "description.h" +#include "netcdf.inc" + +c Arguments: +c ---------- + + CHARACTER*(*) fichnom + INTEGER nq + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nq),masse(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL time + INTEGER length + PARAMETER (length=100) + REAL tab_cntrl(length) ! tableau des parametres du run + +c Variables +c + INTEGER iq,i,j,ij,l + INTEGER ierr, nid, nvarid + +c local, cas particulier compo.dat + integer nyread + real qy(jjp1,llm,nq) + character*10 nomy(nq) + +c----------------------------------------------------------------------- + +c Ouverture NetCDF du fichier etat initial + + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start.nc' + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echoue pour " + CALL abort + ENDIF + + im = tab_cntrl(1) + jm = tab_cntrl(2) + lllm = tab_cntrl(3) + day_ref = tab_cntrl(4) + annee_ref = tab_cntrl(5) + rad = tab_cntrl(6) + omeg = tab_cntrl(7) + g = tab_cntrl(8) + cpp = tab_cntrl(9) + kappa = tab_cntrl(10) + daysec = tab_cntrl(11) + dtvr = tab_cntrl(12) + etot0 = tab_cntrl(13) + ptot0 = tab_cntrl(14) + ztot0 = tab_cntrl(15) + stot0 = tab_cntrl(16) + ang0 = tab_cntrl(17) + pa = tab_cntrl(18) + preff = tab_cntrl(19) +c + clon = tab_cntrl(20) + clat = tab_cntrl(21) + grossismx = tab_cntrl(22) + grossismy = tab_cntrl(23) +c + IF ( tab_cntrl(24).EQ.1. ) THEN + fxyhypb = . TRUE . +c dzoomx = tab_cntrl(25) +c dzoomy = tab_cntrl(26) +c taux = tab_cntrl(28) +c tauy = tab_cntrl(29) + ELSE + fxyhypb = . FALSE . + ysinus = . FALSE . + IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. + ENDIF + + day_ini = tab_cntrl(30) + itau_dyn = tab_cntrl(31) + start_time = tab_cntrl(32) +c ................................................................. +c +c + PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa + + IF( im.ne.iim ) THEN + PRINT 1,im,iim + STOP + ELSE IF( jm.ne.jjm ) THEN + PRINT 2,jm,jjm + STOP + ELSE IF( lllm.ne.llm ) THEN + PRINT 3,lllm,llm + STOP + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour rlatv" + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "nivsigs", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, nivsigs) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, nivsigs) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "nivsig", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, nivsig) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, nivsig) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ap", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ap) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ap) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "bp", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, bp) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, bp) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "presnivs", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, presnivs) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, presnivs) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "aire", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, aire) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "phisinit", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, phis) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, time) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ucov) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, vcov) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, teta) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + +c TNAME: IL EST LU A PARTIR DE traceur.def (mettre l'ancien si +c changement du nombre de traceurs) + + IF((nq.GE.1).and.(iflag_trac.eq.1)) THEN + DO iq=1,nq + ierr = NF_INQ_VARID (nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent" + PRINT*, " Il est donc initialise a zero" + q(:,:,iq)=0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq)) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour "//tname(iq) + CALL abort + ENDIF + ENDIF + ENDDO + ENDIF + +c-------------------------------------------- +c cas particulier: lecture des traceurs 2D dans compo.dat (issu de start 2d) +c + if (1.eq.0) then + OPEN(10,file='compo.dat',status='old',form='formatted', + . iostat=ierr) + IF (ierr.ne.0) THEN + WRITE(6,*)' Pb d''ouverture du fichier de demarrage (compo.dat)' + WRITE(6,*)' ierr = ', ierr + CALL exit(1) + ENDIF + READ(10,*) nyread + print*,"nombre de composes chimiques ajoutes:",nyread + READ(10,*) (((qy(ij,l,iq),ij=1,jjp1),l=1,llm), + s iq=1,nyread) + do iq=1,nyread + READ(10,'(1X,A10)') nomy(iq) + print*,nomy(iq)," = ", tname(iq+10) + do i=1,iip1 + do j=1,jjp1 + ij = (j-1)*iip1+i + q(ij,:,iq+10) = qy(j,:,iq) + enddo + enddo + enddo + CLOSE(10) + endif +c-------------------------------------------- + + ierr = NF_INQ_VARID (nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, masse) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ps) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_CLOSE(nid) + + day_ini=day_ini+INT(time) + time=time-INT(time) + + 1 FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree iim =',i4//) + 2 FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree jjm =',i4//) + 3 FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur parametree llm =',i4//) + 4 FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur dtinteg =',i4//) + + RETURN + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/readstartphy.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/readstartphy.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/readstartphy.F (revision 1540) @@ -0,0 +1,477 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/phyetat0.F,v 1.2 2004/06/22 11:45:33 lmdzadmin Exp $ +! +c +c + SUBROUTINE readstartphy(fichnom, + . rlat,rlon, tsol,tsoil, + . albe, solsw, sollw, + . fder,radsol, + . zmea, zstd, zsig, zgam, zthe, zpic, zval, + . tabcntr0) +c====================================================================== +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Lecture de l'etat initial pour la physique +c====================================================================== + use dimphy + IMPLICIT none +#include "dimensions.h" +#include "netcdf.inc" +#include "dimsoil.h" +c====================================================================== + integer ngridmx + parameter (ngridmx=(2+(jjm-1)*iim - 1/jjm)) + + CHARACTER*(*) fichnom + REAL rlat(ngridmx), rlon(ngridmx) + REAL tsol(ngridmx) + REAL tsoil(ngridmx,nsoilmx) + REAL albe(ngridmx) +cIM BEG alblw + REAL alblw(ngridmx) +cIM END alblw + REAL radsol(ngridmx) + REAL sollw(ngridmx) + real solsw(ngridmx) + real fder(ngridmx) + REAL zmea(ngridmx), zstd(ngridmx) + REAL zsig(ngridmx), zgam(ngridmx), zthe(ngridmx) + REAL zpic(ngridmx), zval(ngridmx) + INTEGER length + PARAMETER (length=100) + REAL tabcntr0(length) + + REAL xmin, xmax +c + INTEGER nid, nvarid + INTEGER ierr, i, nsrf, isoil + CHARACTER*2 str2 +c +c Ouvrir le fichier contenant l'etat initial: +c + print*,'fichnom',fichnom + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier '//fichnom + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Lecture des parametres de controle: +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tabcntr0) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tabcntr0) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF +c +c +c Lecture des latitudes (coordonnees): +c + ierr = NF_INQ_VARID (nid, "latitude", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlat) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlat) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF +c +c Lecture des longitudes (coordonnees): +c + ierr = NF_INQ_VARID (nid, "longitude", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlon) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlon) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF +C +c Lecture des temperatures du sol: +c + ierr = NF_INQ_VARID (nid, "TS", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ELSE + PRINT*, 'phyetat0: Le champ est present' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tsol) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(tsol(i),xmin) + xmax = MAX(tsol(i),xmax) + ENDDO + PRINT*,'Temperature du sol ', xmin, xmax + ENDIF +c +c Lecture des temperatures du sol profond: +c + DO isoil=1, nsoilmx + IF (isoil.GT.99) THEN + PRINT*, "Trop de couches" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') isoil + ierr = NF_INQ_VARID (nid, 'Tsoil'//str2, nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, " Il prend donc la valeur de surface" + DO i=1, ngridmx + tsoil(i,isoil)=tsol(i) + ENDDO + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsoil(1,isoil)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tsoil(1,isoil)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "Lecture echouee pour " + CALL abort + ENDIF + ENDIF + ENDDO + +c +c Lecture de albedo au sol: +c + ierr = NF_INQ_VARID (nid, "ALBE", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ELSE + PRINT*, 'phyetat0: Le champ est present' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, albe(1)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, albe(1)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(albe(i),xmin) + xmax = MAX(albe(i),xmax) + ENDDO + PRINT*,'Albedo du sol ', xmin, xmax + ENDIF + +c +c Lecture rayonnement solaire au sol: +c + ierr = NF_INQ_VARID (nid, "solsw", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + solsw = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, solsw) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, solsw) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(solsw(i),xmin) + xmax = MAX(solsw(i),xmax) + ENDDO + PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax +c +c Lecture rayonnement IF au sol: +c + ierr = NF_INQ_VARID (nid, "sollw", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + sollw = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, sollw) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, sollw) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(sollw(i),xmin) + xmax = MAX(sollw(i),xmax) + ENDDO + PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax + +c +c Lecture derive des flux: +c + ierr = NF_INQ_VARID (nid, "fder", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + fder = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, fder) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, fder) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(fder(i),xmin) + xmax = MAX(fder(i),xmax) + ENDDO + PRINT*,'Derive des flux fder:', xmin, xmax + +c +c Lecture du rayonnement net au sol: +c + ierr = NF_INQ_VARID (nid, "RADS", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, radsol) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, radsol) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(radsol(i),xmin) + xmax = MAX(radsol(i),xmax) + ENDDO + PRINT*,'Rayonnement net au sol radsol:', xmin, xmax + +c +c Lecture des parametres orographie sous-maille: +c + ierr = NF_INQ_VARID (nid, "ZMEA", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zmea = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmea) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zmea) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(zmea(i),xmin) + xmax = MAX(zmea(i),xmax) + ENDDO + PRINT*,'zmea:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZSTD", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zstd = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zstd) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zstd) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(zstd(i),xmin) + xmax = MAX(zstd(i),xmax) + ENDDO + PRINT*,'zstd:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZSIG", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zsig = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zsig) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zsig) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(zsig(i),xmin) + xmax = MAX(zsig(i),xmax) + ENDDO + PRINT*,'zsig:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZGAM", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zgam = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zgam) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zgam) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(zgam(i),xmin) + xmax = MAX(zgam(i),xmax) + ENDDO + PRINT*,'zgam:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZTHE", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zthe = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zthe) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zthe) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(zthe(i),xmin) + xmax = MAX(zthe(i),xmax) + ENDDO + PRINT*,'zthe:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZPIC", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zpic = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zpic) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zpic) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(zpic(i),xmin) + xmax = MAX(zpic(i),xmax) + ENDDO + PRINT*,'zpic:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZVAL", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zval = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zval) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zval) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, ngridmx + xmin = MIN(zval(i),xmin) + xmax = MAX(zval(i),xmax) + ENDDO + PRINT*,'zval:', xmin, xmax +c +c Fermer le fichier: +c + ierr = NF_CLOSE(nid) +c + RETURN + END + Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/scal_wind.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/scal_wind.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/scal_wind.F (revision 1540) @@ -0,0 +1,54 @@ + SUBROUTINE scal_wind(xus,xvs,xu,xv) +c======================================================================= +c +c +c Subject: +c ------ +c On passe les variable xus, xvs aux points de vent u et v (xu et xv) +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" + +c Arguments: +c ---------- + + REAL xu(iip1,jjp1,llm),xv(iip1,jjm,llm) + REAL xus(iip1,jjp1,llm), xvs (iip1,jjp1,llm) + +c Local: +c ------ + + INTEGER i,j,l + +c----------------------------------------------------------------------- + +c transport zonal: +c ---------------- + DO l=1,llm + Do j=1,jjp1 + DO i=1,iim + xu(i,j,l)=0.5*(xus(i,j,l)+xus(i+1,j,l)) + ENDDO + xu(iip1,j,l)=xu(1,j,l) + ENDDO + ENDDO + + +c Transport meridien: +c ------------------- + DO l=1,llm + DO j=1,jjm + do i=1 ,iip1 + xv(i,j,l)=.5*(xvs(i,j,l)+xvs(i,j+1,l)) + end do + ENDDO + ENDDO + + RETURN + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/start2archive.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/start2archive.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/start2archive.F (revision 1540) @@ -0,0 +1,317 @@ +c======================================================================= + PROGRAM start2archive +c======================================================================= +c +c +c Date: 01/1997 +c ---- +c +c Version Venus: 09/2007 +c Titan: 02/2009 +c +c Objet: Passage des fichiers netcdf d etat initial "start" et +c ----- "startphy" a un fichier netcdf unique "start_archive" +c +c======================================================================= + + USE filtreg_mod + USE infotrac + USE control_mod + use cpdet_mod, only: tpot2t,ini_cpdet + use exner_hyb_m, only: exner_hyb + use exner_milieu_m, only: exner_milieu + USE comconst_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + USE logic_mod, ONLY: iflag_trac + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comdissnew.h" +#include "comgeom.h" +#include "description.h" +#include "dimsoil.h" +#include "netcdf.inc" + +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + +c variables dynamiques du GCM +c ----------------------------- + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL, ALLOCATABLE, DIMENSION(:,:,:):: q! champs advectes + REAL pks(ip1jmp1) ! exner (f pour filtre) + REAL pk(ip1jmp1,llm) + REAL pkf(ip1jmp1,llm) + REAL alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm) + REAL phis(ip1jmp1) ! geopotentiel au sol + REAL masse(ip1jmp1,llm) ! masse de l'atmosphere + REAL ps(ip1jmp1) ! pression au sol + REAL p3d(iip1, jjp1, llm+1) ! pression aux interfaces + +c Variable Physiques (grille physique) +c ------------------------------------ + integer ngridmx,nlayermx + parameter (ngridmx=(2+(jjm-1)*iim - 1/jjm)) + parameter (nlayermx=llm) + + real rlat(ngridmx),rlon(ngridmx) + REAL tsurf(ngridmx),tsoil(ngridmx,nsoilmx) + REAL albe(ngridmx),radsol(ngridmx),sollw(ngridmx) + real solsw(ngridmx),dlw(ngridmx) + REAL zmea(ngridmx), zstd(ngridmx) + REAL zsig(ngridmx), zgam(ngridmx), zthe(ngridmx) + REAL zpic(ngridmx), zval(ngridmx) + + INTEGER start,length + PARAMETER (length = 100) + REAL tab_cntrl_fi(length) ! tableau des parametres de startfi + REAL tab_cntrl_dyn(length) ! tableau des parametres de start + INTEGER*4 day_ini_fi + +c Variable naturelle / grille scalaire +c ------------------------------------ + REAL T(ip1jmp1,llm),us(ip1jmp1,llm),vs(ip1jmp1,llm) + REAL tsurfS(ip1jmp1),tsoilS(ip1jmp1,nsoilmx) + real rlatS(ip1jmp1),rlonS(ip1jmp1) + real albeS(ip1jmp1),radsolS(ip1jmp1),sollwS(ip1jmp1) + real solswS(ip1jmp1),dlwS(ip1jmp1) + real zmeaS(ip1jmp1),zstdS(ip1jmp1),zsigS(ip1jmp1) + real zgamS(ip1jmp1),ztheS(ip1jmp1),zpicS(ip1jmp1) + real zvalS(ip1jmp1) + +c Variables intermediaires : vent naturel, mais pas coord scalaire +c---------------------------------------------------------------- + REAL vn(ip1jm,llm),un(ip1jmp1,llm) + +c Autres variables +c ----------------- + REAL ptotal + + CHARACTER*2 str2 + + INTEGER ij, l,i,j,isoil,iq + character*80 fichnom + integer :: ierr + +c Netcdf +c------- + integer varid,dimid + INTEGER nid + +c----------------------------------------------------------------------- +c Initialisations +c----------------------------------------------------------------------- + +c VENUS/TITAN + + iflag_trac = 1 +c----------------------------------------------------------------------- +c Initialisation des traceurs +c --------------------------- +c Choix du nombre de traceurs et du schema pour l advection +c dans fichier traceur.def, par default ou via INCA + call infotrac_init + +c Allocation de la tableau q : champs advectes + allocate(q(ip1jmp1,llm,nqtot)) + +c======================================================================= +c Lecture des donnees +c======================================================================= + + fichnom = 'start.nc' + CALL readstart(fichnom,nqtot,vcov,ucov,teta,q,masse, + . ps,phis,tab_cntrl_dyn) + + fichnom = 'startphy.nc' + CALL readstartphy(fichnom, + . rlat,rlon,tsurf,tsoil, + . albe, solsw, sollw, + . dlw,radsol, + . zmea,zstd,zsig,zgam,zthe,zpic,zval, + . tab_cntrl_fi) + +c----------------------------------------------------------------------- +c Initialisations +c----------------------------------------------------------------------- + + CALL conf_gcm( 99, .TRUE. ) + call iniconst + call inigeom + call inifilr + call ini_cpdet + + CALL pression(ip1jmp1, ap, bp, ps, p3d) + if (disvert_type==1) then + CALL exner_hyb( ip1jmp1, ps, p3d, pks, pk, pkf ) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu( ip1jmp1, ps, p3d, pks, pk, pkf ) + endif + +c======================================================================= +c Transformation EN VARIABLE NATURELLE / GRILLE SCALAIRE si necessaire +c======================================================================= +c Les variables modeles dependent de la resolution. Il faut donc +c eliminer les facteurs responsables de cette dependance +c (pour utiliser newstart) +c======================================================================= + +c----------------------------------------------------------------------- +c Vent (depend de la resolution horizontale) +c----------------------------------------------------------------------- +c +c ucov --> un et vcov --> vn +c un --> us et vn --> vs +c +c----------------------------------------------------------------------- + + call covnat(llm,ucov, vcov, un, vn) + call wind_scal(un,vn,us,vs) + +c----------------------------------------------------------------------- +c Temperature (depend de la resolution verticale => de "sigma.def") +c----------------------------------------------------------------------- +c +c h --> T +c +c----------------------------------------------------------------------- +! ADAPTATION GCM POUR CP(T) + + call tpot2t(ip1jmp1*llm,teta,T,pk) + +c----------------------------------------------------------------------- +c Variable physique +c----------------------------------------------------------------------- +c +c tsurf --> tsurfS +c et autres... +c +c----------------------------------------------------------------------- + + call gr_fi_dyn(1,ngridmx,iip1,jjp1,tsurf,tsurfS) + call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,tsoil,tsoilS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,rlat,rlatS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,rlon,rlonS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,albe,albeS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,radsol,radsolS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,sollw,sollwS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,solsw,solswS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,dlw,dlwS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zmea,zmeaS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zstd,zstdS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zsig,zsigS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zgam,zgamS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zthe,ztheS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zpic,zpicS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zval,zvalS) + +c======================================================================= +c Info pour controler +c======================================================================= + + ptotal = 0. + DO j=1,jjp1 + DO i=1,iim + ptotal=ptotal+aire(i+(iim+1)*(j-1))*ps(i+(iim+1)*(j-1))/g + ENDDO + ENDDO + write(*,*)'Ancienne grille : masse de l''atm :',ptotal + +c----------------------------------------------------------------------- +c Passage de "ptotal" par tab_cntrl_fi +c----------------------------------------------------------------------- + + tab_cntrl_fi(length) = ptotal + +c======================================================================= +c Ecriture dans le fichier "start_archive" +c======================================================================= + +c----------------------------------------------------------------------- +c Ouverture de "start_archive" +c----------------------------------------------------------------------- + + ierr = NF_OPEN ('start_archive.nc', NF_WRITE,nid) + +c----------------------------------------------------------------------- +c si "start_archive" n'existe pas: +c 1_ ouverture +c 2_ creation de l'entete dynamique ("ini_archive") +c----------------------------------------------------------------------- +c ini_archive: +c On met dans l'entete le tab_cntrl_dyn (1 a length) +c On y ajoute les valeurs du tab_cntrl_fi (length+1 a 2*length) +c----------------------------------------------------------------------- + + if (ierr.ne.NF_NOERR) then + write(*,*)'OK, Could not open file "start_archive.nc"' + write(*,*)'So let s create a new "start_archive"' + ierr = NF_CREATE('start_archive.nc', NF_CLOBBER, nid) + call ini_archive(nid,phis,tab_cntrl_dyn,tab_cntrl_fi) + else + write(*,*)'Attention, start_archive.nc existe deja...' + call abort + endif + +c----------------------------------------------------------------------- +c Ecriture des champs +c----------------------------------------------------------------------- + + call write_archive(nid,'u','Vent zonal','m.s-1',3,us) + call write_archive(nid,'v','Vent merid','m.s-1',3,vs) + call write_archive(nid,'temp','temperature','K',3,T) +c----------------------------------------------------------------------- +c Ecriture du champs q ( q[1,nqtot] ) +c----------------------------------------------------------------------- + do iq=1,nqtot + write(str2,'(i2.2)') iq + call write_archive(nid,tname(iq),'tracer','kg/kg', + . 3,q(1,1,iq)) + end do +c----------------------------------------------------------------------- + call write_archive(nid,'masse','Masse','kg',3,masse) + call write_archive(nid,'ps','Psurf','Pa',2,ps) + call write_archive(nid,'tsurf','surf T','K',2,tsurfS) +c----------------------------------------------------------------------- +c Ecriture du champs tsoil ( Tsoil[1,nsoilmx] ) +c----------------------------------------------------------------------- +c "tsoil" Temperature au sol definie dans nsoilmx couches dans le sol +c Les nsoilmx couches sont lues comme nsoilmx champs +c nommees Tsoil[1,nsoilmx] + do isoil=1,nsoilmx + write(str2,'(i2.2)') isoil + call write_archive(nid,'Tsoil'//str2,'Ground Temperature ', + . 'K',2,tsoilS(1,isoil)) + enddo +c----------------------------------------------------------------------- + call write_archive(nid,'rlat','Latitude','rad',2,rlatS) + call write_archive(nid,'rlon','Longitude','rad',2,rlonS) + call write_archive(nid,'albe','Albedo','',2,albeS) + call write_archive(nid,'radsol', + . 'Net flux at surface','W m-2',2,radsolS) + call write_archive(nid,'sollw', + . 'LW flux at surface','W m-2',2,sollwS) + call write_archive(nid,'solsw', + . 'SW flux at surface','W m-2',2,solswS) + call write_archive(nid,'dlw','LW derive','?',2,dlwS) + call write_archive(nid,'zmea','param oro sous-maille','m',2,zmeaS) + call write_archive(nid,'zstd','param oro sous-maille','m',2,zstdS) + call write_archive(nid,'zsig','param oro sous-maille','m',2,zsigS) + call write_archive(nid,'zgam','param oro sous-maille','m',2,zgamS) + call write_archive(nid,'zthe','param oro sous-maille','m',2,ztheS) + call write_archive(nid,'zpic','param oro sous-maille','m',2,zpicS) + call write_archive(nid,'zval','param oro sous-maille','m',2,zvalS) + + ierr=NF_CLOSE(nid) + +c----------------------------------------------------------------------- +c Fin +c----------------------------------------------------------------------- + + end Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/startvar.F90 =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/startvar.F90 (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/startvar.F90 (revision 1540) @@ -0,0 +1,771 @@ +! +! $Id: startvar.F90 1425 2010-09-02 13:45:23Z lguez $ +! +!******************************************************************************* +! +MODULE startvar +! +!******************************************************************************* +! +!------------------------------------------------------------------------------- +! Purpose: Access data from the database of atmospheric to initialize the model. +!------------------------------------------------------------------------------- +! Comments: +! +! * This module is designed to work for Earth (and with ioipsl) +! +! * There are three ways to acces data, depending on the type of field +! which needs to be extracted. In any case the call should come after a restget +! and should be of the type : CALL startget(...) +! +! - A 1D variable on the physical grid : +! CALL startget_phys1d((varname, iml, jml, lon_in, lat_in, nbindex, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! - A 2D variable on the dynamical grid : +! CALL startget_phys2d(varname, iml, jml, lon_in, lat_in, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! - A 3D variable on the dynamical grid : +! CALL startget_dyn((varname, iml, jml, lon_in, lat_in, lml, pls, workvar, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! * Data needs to be in NetCDF format +! +! * Variables should have the following names in the files: +! 'RELIEF' : High resolution orography +! 'ST' : Surface temperature +! 'CDSW' : Soil moisture +! 'Z' : Surface geopotential +! 'SP' : Surface pressure +! 'U' : East ward wind +! 'V' : Northward wind +! 'TEMP' : Temperature +! 'R' : Relative humidity +! +! * There is a big mess with the longitude size. Should it be iml or iml+1 ? +! I have chosen to use the iml+1 as an argument to this routine and we declare +! internaly smaller fields when needed. This needs to be cleared once and for +! all in LMDZ. A convention is required. +!------------------------------------------------------------------------------- + USE ioipsl + IMPLICIT NONE + + PRIVATE + PUBLIC startget_phys2d, startget_phys1d, startget_dyn +! INTERFACE startget +! MODULE PROCEDURE startget_phys1d, startget_phys2d, startget_dyn +! END INTERFACE + + REAL, SAVE :: deg2rad, pi + INTEGER, SAVE :: iml_rel, jml_rel + INTEGER, SAVE :: fid_phys, iml_phys, jml_phys + INTEGER, SAVE :: fid_dyn, iml_dyn, jml_dyn, llm_dyn, ttm_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lon_phys, lon_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lat_phys, lat_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lon_rug, lon_alb, lon_rel + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lat_rug, lat_alb, lat_rel + REAL, DIMENSION(:), ALLOCATABLE, TARGET, SAVE :: levdyn_ini + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: relief, zstd, zsig, zgam + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: zthe, zpic, zval + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: rugo, phis, tsol, qsol + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: psol_dyn + REAL, DIMENSION(:,:,:), ALLOCATABLE, TARGET, SAVE :: var_ana3d + + CONTAINS + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, lat_in, nbindex, champ, & + val_exp ,jml2, lon_in2, lat_in2, ibar) +! +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: nbindex + REAL, DIMENSION(nbindex), INTENT(INOUT) :: champ + REAL, INTENT(IN) :: val_exp + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(:,:), POINTER :: v2d +!------------------------------------------------------------------------------- + v2d=>NULL() + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + +!--- CHECKING IF THE FIELD IS KNOWN ; READING UNALLOCATED FILES + SELECT CASE(varname) + CASE('tsol') + IF(.NOT.ALLOCATED(tsol)) & + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('qsol') + IF(.NOT.ALLOCATED(qsol)) & + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('psol') + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn (iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('zmea','zstd','zsig','zgam','zthe','zpic','zval') + IF(.NOT.ALLOCATED(relief)) & + CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('rads','snow','tslab','seaice','rugmer','agsno') + CASE DEFAULT + WRITE(lunout,*)'startget_phys1d' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + +!--- SELECTING v2d FOR WANTED VARIABLE AND CHEKING ITS SIZE + SELECT CASE(varname) + CASE('rads','snow','tslab','seaice'); champ=0.0 + CASE('rugmer'); champ(:)=0.001 + CASE('agsno'); champ(:)=50.0 + CASE DEFAULT + SELECT CASE(varname) + CASE('tsol'); v2d=>tsol + CASE('qsol'); v2d=>qsol + CASE('psol'); v2d=>psol_dyn + CASE('zmea'); v2d=>relief + CASE('zstd'); v2d=>zstd + CASE('zsig'); v2d=>zsig + CASE('zgam'); v2d=>zgam + CASE('zthe'); v2d=>zthe + CASE('zpic'); v2d=>zpic + CASE('zval'); v2d=>zval + END SELECT + IF(SIZE(v2d)/=SIZE(lon_in)*SIZE(lat_in)) THEN + WRITE(lunout,*)'STARTVAR module has been initialized to the wrong size' + STOP + END IF + CALL gr_dyn_fi(1,iml,jml,nbindex,v2d,champ) + END SELECT + + ELSE + +!--- SOME FIELDS ARE CAUGHT: MAY BE NEEDED FOR A 3D INTEPROLATION + SELECT CASE(varname) + CASE('tsol') + IF(.NOT.ALLOCATED(tsol)) ALLOCATE(tsol(iml,jml)) + CALL gr_fi_dyn(1,iml,jml,nbindex,champ,tsol) + END SELECT + + END IF + +END SUBROUTINE startget_phys1d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in, champ, val_exp, & + jml2, lon_in2, lat_in2 , ibar) +! +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + REAL, DIMENSION(iml,jml), INTENT(INOUT) :: champ + REAL, INTENT(IN) :: val_exp + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(:,:), POINTER :: v2d=>NULL() +!------------------------------------------------------------------------------- + v2d=>NULL() + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + +!--- CHECKING IF THE FIELD IS KNOWN ; READING UNALLOCATED FILES + SELECT CASE(varname) + CASE('psol') + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn (iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('relief') + IF(.NOT.ALLOCATED(relief)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('surfgeo') + IF(.NOT.ALLOCATED(phis)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('rugosite') + IF(.NOT.ALLOCATED(rugo)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE DEFAULT + WRITE(lunout,*)'startget_phys2d' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + +!--- SELECTING v2d FOR WANTED VARIABLE AND CHEKING ITS SIZE + SELECT CASE(varname) + CASE('psol'); v2d=>psol_dyn + CASE('relief'); v2d=>relief + CASE('rugosite'); v2d=>rugo + CASE('surfgeo'); v2d=>phis + END SELECT + IF(SIZE(champ)/=SIZE(v2d)) THEN + WRITE(lunout,*) 'STARTVAR module has been initialized to the wrong size' + STOP + END IF + + champ(:,:)=v2d(:,:) + + ELSE + +!--- SOME FIELDS ARE CAUGHT: MAY BE NEEDED FOR A 3D INTEPROLATION + SELECT CASE(varname) + CASE ('surfgeo') + IF(.NOT.ALLOCATED(phis)) ALLOCATE(phis(iml,jml)) + IF(SIZE(phis)/=SIZE(champ)) THEN + WRITE(lunout,*)'STARTVAR module has been initialized to the wrong size' + STOP + END IF + phis(:,:)=champ(:,:) + END SELECT + + END IF + +END SUBROUTINE startget_phys2d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_dyn(varname, lon_in, lat_in, pls,workvar,& + champ, val_exp, lon_in2, lat_in2, ibar) + + use assert_eq_m, only: assert_eq + USE comconst_mod + +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + REAL, INTENT(IN) :: lon_in(:) ! dim(iml) + REAL, INTENT(IN) :: lat_in(:) ! dim(jml) + REAL, INTENT(IN) :: pls(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(IN) :: workvar(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(INOUT) :: champ(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(IN) :: val_exp + REAL, INTENT(IN) :: lon_in2(:) ! dim(iml) + REAL, INTENT(IN) :: lat_in2(:) ! dim(jml2) + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + INTEGER :: iml, jml + INTEGER :: lml + INTEGER :: jml2 + REAL, DIMENSION(:,:,:), POINTER :: v3d=>NULL() + CHARACTER(LEN=10) :: vname + INTEGER :: il + REAL :: xppn, xpps +!------------------------------------------------------------------------------- + NULLIFY(v3d) + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + + iml = assert_eq((/size(lon_in), size(pls, 1), size(workvar, 1), & + & size(champ, 1), size(lon_in2)/), "startget_dyn iml") + jml = assert_eq(size(lat_in), size(pls, 2), size(workvar, 2), & + & size(champ, 2), "startget_dyn jml") + lml = assert_eq(size(pls, 3), size(workvar, 3), size(champ, 3), & + & "startget_dyn lml") + jml2 = size(lat_in2) + +!--- READING UNALLOCATED FILES + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + +!--- CHECKING IF THE FIELD IS KNOWN AND INTERPOLATING 3D FIELDS + SELECT CASE(varname) + CASE('u'); vname='U' + CASE('v'); vname='V' + CASE('t','tpot'); vname='TEMP' + CASE('q'); vname='R' + CASE DEFAULT + WRITE(lunout,*)'startget_dyn' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + CALL start_inter_3d(TRIM(vname), iml, jml, lml, lon_in, lat_in, jml2, & + lon_in2, lat_in2, pls, champ,ibar ) + +!--- COMPUTING THE REQUIRED FILED + SELECT CASE(varname) + CASE('u') !--- Eastward wind + DO il=1,lml; champ(:,:,il)=champ(:,:,il)*cu(:,1:jml); END DO + champ(iml,:,:)=champ(1,:,:) + + CASE('v') !--- Northward wind + DO il=1,lml; champ(:,:,il)=champ(:,:,il)*cv(:,1:jml); END DO + champ(iml,:,:)=champ(1,:,:) + + CASE('tpot') !--- Temperature + IF(MINVAL(workvar)/=MAXVAL(workvar)) THEN + champ=champ*cpp/workvar + DO il=1,lml + xppn = SUM(aire(:,1 )*champ(:,1 ,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1 ,il) = xppn + champ(:,jml,il) = xpps + END DO + ELSE + WRITE(lunout,*)'Could not compute potential temperature as the' + WRITE(lunout,*)'Exner function is missing or constant.'; STOP + END IF + + CASE('q') !--- Relat. humidity + IF(MINVAL(workvar)/=MAXVAL(workvar)) THEN + champ=0.01*champ*workvar + WHERE(champ<0.) champ=1.0E-10 + DO il=1,lml + xppn = SUM(aire(:,1 )*champ(:,1 ,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1 ,il) = xppn + champ(:,jml,il) = xpps + END DO + ELSE + WRITE(lunout,*)'Could not compute specific humidity as the' + WRITE(lunout,*)'saturated humidity is missing or constant.'; STOP + END IF + + END SELECT + + END IF + +END SUBROUTINE startget_dyn +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_orog(iml,jml,lon_in,lat_in) + USE comconst_mod + USE grid_atob_m, ONLY: rugsoro + +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: orofname + LOGICAL :: check=.TRUE. + REAL, DIMENSION(1) :: lev + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: fid, llm_tmp, ttm_tmp + REAL, DIMENSION(:,:), ALLOCATABLE :: relief_hi, tmp_var + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini +!------------------------------------------------------------------------------- + pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + + orofname = 'Relief.nc'; title='RELIEF' + IF(check) WRITE(lunout,*)'Reading the high resolution orography' + CALL flininfo(orofname, iml_rel, jml_rel, llm_tmp, ttm_tmp, fid) + + ALLOCATE(lat_rel(iml_rel,jml_rel),lon_rel(iml_rel,jml_rel)) + CALL flinopen(orofname, .FALSE., iml_rel, jml_rel, llm_tmp, lon_rel, lat_rel,& + lev, ttm_tmp, itau, date, dt, fid) + ALLOCATE(relief_hi(iml_rel,jml_rel)) + CALL flinget(fid, title, iml_rel, jml_rel, llm_tmp, ttm_tmp, 1, 1, relief_hi) + CALL flinclo(fid) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_rel),lat_ini(jml_rel)) + lon_ini(:)=lon_rel(:,1); IF(MAXVAL(lon_rel)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_rel(1,:); IF(MAXVAL(lat_rel)>pi) lat_ini=lat_ini*deg2rad + +!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS + ALLOCATE(lon_rad(iml_rel),lat_rad(jml_rel)) + CALL conf_dat2d(title, iml_rel, jml_rel, lon_ini, lat_ini, lon_rad, lat_rad, & + relief_hi, .FALSE.) + DEALLOCATE(lon_ini,lat_ini) + +!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro + IF(check) WRITE(lunout,*)'Computes all parameters needed for gravity wave dra& + &g code' + + ALLOCATE(phis(iml,jml)) ! Geopotentiel au sol + ALLOCATE(zstd(iml,jml)) ! Deviation standard de l'orographie sous-maille + ALLOCATE(zsig(iml,jml)) ! Pente de l'orographie sous-maille + ALLOCATE(zgam(iml,jml)) ! Anisotropie de l'orographie sous maille + ALLOCATE(zthe(iml,jml)) ! Orientation axe +grande pente d'oro sous maille + ALLOCATE(zpic(iml,jml)) ! Hauteur pics de la SSO + ALLOCATE(zval(iml,jml)) ! Hauteur vallees de la SSO + ALLOCATE(relief(iml,jml)) ! Orographie moyenne + + CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, iml-1, jml, & + lon_in, lat_in, phis, relief, zstd, zsig, zgam, zthe, zpic, zval) + phis = phis * g + +!--- SURFACE ROUGHNESS COMPUTATION (UNUSED FOR THE MOMENT !!! ) + IF(check) WRITE(lunout,*)'Compute surface roughness induced by the orography' + ALLOCATE(rugo (iml ,jml)) + ALLOCATE(tmp_var(iml-1,jml)) + CALL rugsoro(lon_rad, lat_rad, relief_hi, & + lon_in, lat_in, tmp_var) + rugo(1:iml-1,:)=tmp_var; rugo(iml,:)=tmp_var(1,:) + DEALLOCATE(relief_hi,tmp_var,lon_rad,lat_rad) + RETURN + +END SUBROUTINE start_init_orog +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: physfname + LOGICAL :: check=.TRUE. + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: llm_tmp, ttm_tmp + REAL, DIMENSION(:,:), ALLOCATABLE :: var_ana + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(:), ALLOCATABLE :: levphys_ini +!------------------------------------------------------------------------------- + physfname = 'ECPHY.nc'; pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + IF(check) WRITE(lunout,*)'Opening the surface analysis' + CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp, ttm_tmp, fid_phys) + + ALLOCATE(lat_phys(iml_phys,jml_phys)) + ALLOCATE(lon_phys(iml_phys,jml_phys)) + ALLOCATE(levphys_ini(llm_tmp)) + CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, llm_tmp, lon_phys, & + lat_phys, levphys_ini, ttm_tmp, itau, date, dt, fid_phys) + DEALLOCATE(levphys_ini) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_phys),lat_ini(jml_phys)) + lon_ini(:)=lon_phys(:,1); IF(MAXVAL(lon_phys)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_phys(1,:); IF(MAXVAL(lat_phys)>pi) lat_ini=lat_ini*deg2rad + + ALLOCATE(var_ana(iml_phys,jml_phys),lon_rad(iml_phys),lat_rad(jml_phys)) + +!--- SURFACE TEMPERATURE + title='ST' + ALLOCATE(tsol(iml,jml)) + CALL flinget(fid_phys,title,iml_phys,jml_phys,llm_tmp,ttm_tmp,1,1,var_ana) + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, lon_rad, lat_rad,& + var_ana , ibar ) + CALL interp_startvar(title, ibar, .TRUE., & + iml_phys, jml_phys, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, tsol) + +!--- SOIL MOISTURE + title='CDSW' + ALLOCATE(qsol(iml,jml)) + CALL flinget(fid_phys,title,iml_phys,jml_phys,llm_tmp,ttm_tmp,1,1,var_ana) + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, lon_rad, lat_rad,& + var_ana, ibar ) + CALL interp_startvar(title, ibar, .TRUE., & + iml_phys, jml_phys, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, qsol) + + CALL flinclo(fid_phys) + + DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini) + +END SUBROUTINE start_init_phys +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_dyn(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: physfname + LOGICAL :: check=.TRUE. + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: i, j + REAL, DIMENSION(:,:), ALLOCATABLE :: var_ana, z + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(:), ALLOCATABLE :: xppn, xpps +!------------------------------------------------------------------------------- + +!--- KINETIC ENERGY + physfname = 'ECDYN.nc'; pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + IF(check) WRITE(lunout,*) 'Opening the surface analysis' + CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn, ttm_dyn, fid_dyn) + IF(check) WRITE(lunout,*) 'Values read: ', iml_dyn, jml_dyn, llm_dyn, ttm_dyn + + ALLOCATE(lat_dyn(iml_dyn,jml_dyn)) + ALLOCATE(lon_dyn(iml_dyn,jml_dyn)) + ALLOCATE(levdyn_ini(llm_dyn)) + CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn, lon_dyn,lat_dyn,& + levdyn_ini, ttm_dyn, itau, date, dt, fid_dyn) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_dyn),lat_ini(jml_dyn)) + lon_ini(:)=lon_dyn(:,1); IF(MAXVAL(lon_dyn)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_dyn(1,:); IF(MAXVAL(lat_dyn)>pi) lat_ini=lat_ini*deg2rad + + ALLOCATE(var_ana(iml_dyn,jml_dyn),lon_rad(iml_dyn),lat_rad(jml_dyn)) + +!--- SURFACE GEOPOTENTIAL + title='Z' + ALLOCATE(z(iml,jml)) + CALL flinget(fid_dyn, title, iml_dyn, jml_dyn, 0, ttm_dyn, 1, 1, var_ana) + CALL conf_dat2d(title, iml_dyn, jml_dyn, lon_ini, lat_ini, lon_rad, lat_rad, & + var_ana, ibar) + CALL interp_startvar(title, ibar, .TRUE., & + iml_dyn, jml_dyn, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, z) + +!--- SURFACE PRESSURE + title='SP' + ALLOCATE(psol_dyn(iml,jml)) + CALL flinget(fid_dyn, title, iml_dyn, jml_dyn, 0, ttm_dyn, 1, 1, var_ana) + CALL conf_dat2d(title, iml_dyn, jml_dyn, lon_ini, lat_ini, lon_rad, lat_rad, & + var_ana, ibar) + CALL interp_startvar(title, ibar, .TRUE., & + iml_dyn, jml_dyn, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, psol_dyn) + + DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini) + +!--- ALLOCATION OF VARIABLES CREATED IN OR COMING FROM RESTART FILE + IF(.NOT.ALLOCATED(tsol)) THEN + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + ELSE + IF(SIZE(tsol)/=SIZE(psol_dyn)) THEN + WRITE(lunout,*)'start_init_dyn :' + WRITE(lunout,*)'The temperature field we have does not have the right size' + STOP + END IF + END IF + + IF(.NOT.ALLOCATED(phis)) THEN + CALL start_init_orog(iml,jml,lon_in,lat_in) + ELSE + IF(SIZE(phis)/=SIZE(psol_dyn)) THEN + WRITE(lunout,*)'start_init_dyn :' + WRITE(lunout,*)'The orography field we have does not have the right size' + STOP + END IF + END IF + +!--- PSOL IS COMPUTED IN PASCALS + DO j = 1, jml + DO i = 1, iml-1 + psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j))/287.0/tsol(i,j)) + END DO + psol_dyn(iml,j) = psol_dyn(1,j) + END DO + DEALLOCATE(z) + + ALLOCATE(xppn(iml-1),xpps(iml-1)) + DO i = 1, iml-1 + xppn(i) = aire( i,1) * psol_dyn( i,1) + xpps(i) = aire( i,jml) * psol_dyn( i,jml) + END DO + DO i = 1, iml + psol_dyn(i,1 ) = SUM(xppn)/apoln + psol_dyn(i,jml) = SUM(xpps)/apols + END DO + DEALLOCATE(xppn,xpps) + + RETURN + +END SUBROUTINE start_init_dyn +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in, lat_in, jml2, & + lon_in2, lat_in2, pls_in, var3d, ibar) + + use pchsp_95_m, only: pchsp_95 + use pchfe_95_m, only: pchfe_95 + +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml, lml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + REAL, DIMENSION(iml, jml, lml), INTENT(IN) :: pls_in + REAL, DIMENSION(iml, jml, lml), INTENT(OUT) :: var3d + LOGICAL, INTENT(IN) :: ibar +!---------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + LOGICAL:: check=.TRUE., skip + REAL chmin, chmax + INTEGER ii, ij, il, ierr + integer n_extrap ! number of extrapolated points + REAL, DIMENSION(iml, jml, llm_dyn):: var_tmp3d + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(llm_dyn):: lev_dyn, ax, ay, yder + +!--------------------------------------------------------------------------- + IF(check) WRITE(lunout, *)'Going into flinget to extract the 3D field.' + IF(check) WRITE(lunout, *) fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, & + ttm_dyn + IF(check) WRITE(lunout, *) 'Allocating space for interpolation', iml, jml, & + llm_dyn + + IF(.NOT.ALLOCATED(var_ana3d)) ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn)) + CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, ttm_dyn, 1, 1, & + var_ana3d) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_dyn), lat_ini(jml_dyn)) + lon_ini(:)=lon_dyn(:, 1); IF(MAXVAL(lon_dyn)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_dyn(1, :); IF(MAXVAL(lat_dyn)>pi) lat_ini=lat_ini*deg2rad + +!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS + ALLOCATE(lon_rad(iml_dyn), lat_rad(jml_dyn)) + CALL conf_dat3d (varname, iml_dyn, jml_dyn, llm_dyn, lon_ini, lat_ini, & + levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d, ibar) + DEALLOCATE(lon_ini, lat_ini) + +!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro + DO il=1, llm_dyn + CALL interp_startvar(varname, ibar, il==1, iml_dyn, jml_dyn, lon_rad, & + lat_rad, var_ana3d(:, :, il), iml, jml, jml2, lon_in, lat_in, & + lon_in2, lat_in2, var_tmp3d(:, :, il)) + END DO + DEALLOCATE(lon_rad, lat_rad) + +!--- VERTICAL INTERPOLATION IS PERFORMED FROM TOP OF ATMOSPHERE TO GROUND + ax = lev_dyn(llm_dyn:1:-1) + skip = .false. + n_extrap = 0 + DO ij=1, jml + DO ii=1, iml-1 + ay = var_tmp3d(ii, ij, llm_dyn:1:-1) + yder = pchsp_95(ax, ay, ibeg=2, iend=2, vc_beg=0., vc_end=0.) + CALL pchfe_95(ax, ay, yder, skip, pls_in(ii, ij, lml:1:-1), & + var3d(ii, ij, lml:1:-1), ierr) + if (ierr < 0) stop 1 + n_extrap = n_extrap + ierr + END DO + END DO + if (n_extrap /= 0) then + print *, "start_inter_3d pchfe_95: n_extrap = ", n_extrap + end if + var3d(iml, :, :) = var3d(1, :, :) + + DO il=1, lml + CALL minmax(iml*jml, var3d(1, 1, il), chmin, chmax) + WRITE(lunout, *)' '//TRIM(varname)//' min max l ', il, chmin, chmax + END DO + +END SUBROUTINE start_inter_3d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE interp_startvar(vname, ibar, ibeg, ii, jj, lon, lat, vari, & + i1, j1, j2, lon1, lat1, lon2, lat2, varo) +! +!------------------------------------------------------------------------------- + + USE inter_barxy_m, only: inter_barxy + USE grid_atob_m, only: grille_m + +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: vname + LOGICAL, INTENT(IN) :: ibar, ibeg + INTEGER, INTENT(IN) :: ii, jj + REAL, DIMENSION(ii), INTENT(IN) :: lon + REAL, DIMENSION(jj), INTENT(IN) :: lat + REAL, DIMENSION(ii,jj), INTENT(IN) :: vari + INTEGER, INTENT(IN) :: i1, j1, j2 + REAL, DIMENSION(i1), INTENT(IN) :: lon1 + REAL, DIMENSION(j1), INTENT(IN) :: lat1 + REAL, DIMENSION(i1), INTENT(IN) :: lon2 + REAL, DIMENSION(j2), INTENT(IN) :: lat2 + REAL, DIMENSION(i1,j1), INTENT(OUT) :: varo +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(i1-1,j1) :: vtmp +!------------------------------------------------------------------------------- + IF(ibar) THEN + IF(ibeg) THEN + WRITE(lunout,*) & + '---------------------------------------------------------------' + WRITE(lunout,*) & + '$$$ Utilisation de l interpolation barycentrique pour '//TRIM(vname)//' $$$' + WRITE(lunout,*) & + '---------------------------------------------------------------' + END IF + CALL inter_barxy(lon, lat(:jj-1), vari, lon2(:i1-1), lat2(:j2), vtmp) + ELSE + CALL grille_m (lon, lat, vari, lon1, lat1, vtmp) + END IF + CALL gr_int_dyn(vtmp, varo, i1-1, j1) + +END SUBROUTINE interp_startvar +! +!------------------------------------------------------------------------------- + +END MODULE startvar +! +!******************************************************************************* Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/wind_scal.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/wind_scal.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/wind_scal.F (revision 1540) @@ -0,0 +1,54 @@ + SUBROUTINE wind_scal(pbaru,pbarv,us,vs) +c======================================================================= +c +c +c Subject: +c ------ +c On ramene les flux de masse /vents aux points scalaires. +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" + +c Arguments: +c ---------- + + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL us(ip1jmp1,llm), vs (ip1jmp1,llm) + +c Local: +c ------ + + INTEGER ij,l + +c----------------------------------------------------------------------- + +c transport zonal: +c ---------------- + DO l=1,llm + DO ij=2,ip1jmp1 + us(ij,l)=.5*(pbaru(ij,l)+pbaru(ij-1,l)) + ENDDO + ENDDO + CALL SCOPY(jjp1*llm,us(iip1,1),iip1,us(1,1),iip1) + + +c Transport meridien: +c ------------------- + DO l=1,llm + DO ij=iip2,ip1jm + vs(ij,l)=.5*(pbarv(ij,l)+pbarv(ij-iip1,l)) + ENDDO + DO ij=1,iip1 + vs(ij,l)=0. + vs(ip1jm+ij,l)=0. + ENDDO + ENDDO + + RETURN + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/write_archive.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/write_archive.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/write_archive.F (revision 1540) @@ -0,0 +1,198 @@ +c======================================================================= + subroutine write_archive(nid,nom,titre,unite,dim,px) +c======================================================================= +c +c +c Date: 01/1997 +c ---- +c +c Objet: Ecriture de champs sur grille scalaire (iip1*jjp1) +c ----- dans un fichier DRS nomme "start_archive" +c +c Il faut au prealable avoir cree un entete avec un "call ini_archive". +c Ces variables peuvent etre 3d (ex: temperature), 2d (ex: temperature +c de surface), ou 0d (pour un scalaire qui ne depend que du temps) +c (ex: la longitude solaire) +c +c +c Arguments: +c ---------- +c +c Inputs: +c ------ +c +c nid Unite logique du fichier "start_archive" +c nom nom du champ a ecrire dans le fichier "start_archive" +c titre titre de la variable dans le fichier DRS "start_archive" +c unite unite de la variable .... +c dim dimension de la variable a ecrire +c px tableau contenant la variable a ecrire +c +c +c======================================================================= + + USE control_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "description.h" +#include "netcdf.inc" + +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + +c Arguments: + + INTEGER nid,ntime,dim + REAL px(iip1,jjp1,llm) + + CHARACTER*(*) nom, titre, unite + + integer ierr + + +c local + integer, dimension(4) :: edges,corner,id + integer :: varid,i,j,l + + ntime = 1 + +c----------------------------------------------------------------------- +c Ecriture du champs dans le fichier (3 cas) +c----------------------------------------------------------------------- + +!Cas Variable 3D +!--------------- + if (dim.eq.3) then + +! Ecriture du champs + +! nom de la variable + ierr= NF_INQ_VARID(nid,nom,varid) + if (ierr /= NF_NOERR) then +! choix du nom des coordonnees + ierr= NF_INQ_DIMID(nid,"rlonv",id(1)) + ierr= NF_INQ_DIMID(nid,"rlatu",id(2)) + ierr= NF_INQ_DIMID(nid,"sigs",id(3)) + ierr= NF_INQ_DIMID(nid,"Time",id(4)) + +! Creation de la variable si elle n'existait pas + + write (*,*) "=====================" + write (*,*) "creation de ",nom + call def_var(nid,nom,titre,unite,4,id,varid,ierr) + + endif + + corner(1)=1 + corner(2)=1 + corner(3)=1 + corner(4)=ntime + + edges(1)=iip1 + edges(2)=jjp1 + edges(3)=llm + edges(4)=1 +#ifdef NC_DOUBLE + ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px) +#else + ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px) +#endif + + if (ierr.ne.NF_NOERR) then + write(*,*) "***** PUT_VAR matter in write_archive" + write(*,*) "***** with ",nom," ",nf_STRERROR(ierr) + call abort + endif + +!Cas Variable 2D +!--------------- + + else if (dim.eq.2) then + +! Ecriture du champs + + ierr= NF_INQ_VARID(nid,nom,varid) + if (ierr /= NF_NOERR) then +! choix du nom des coordonnees + ierr= NF_INQ_DIMID(nid,"rlonv",id(1)) + ierr= NF_INQ_DIMID(nid,"rlatu",id(2)) + ierr= NF_INQ_DIMID(nid,"Time",id(3)) + +! Creation de la variable si elle n'existait pas + + write (*,*) "=====================" + write (*,*) "creation de ",nom + + call def_var(nid,nom,titre,unite,3,id,varid,ierr) + + endif + + corner(1)=1 + corner(2)=1 + corner(3)=ntime + edges(1)=iip1 + edges(2)=jjp1 + edges(3)=1 + + +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px) +#else + ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px) +#endif + + if (ierr.ne.NF_NOERR) then + write(*,*) "***** PUT_VAR matter in write_archive" + write(*,*) "***** with ",nom,nf_STRERROR(ierr) + call abort + endif + + +!Cas Variable 0D (scalaire dependant du temps) +!--------------------------------------------- + + else if (dim.eq.0) then + +! Ecriture du champs + + ierr= NF_INQ_VARID(nid,nom,varid) + if (ierr /= NF_NOERR) then +! choix du nom des coordonnees + ierr= NF_INQ_DIMID(nid,"temps",id(1)) + +! Creation de la variable si elle n'existait pas + + write (*,*) "=====================" + write (*,*) "creation de ",nom + + call def_var(nid,nom,titre,unite,1,id,varid,ierr) + + endif + + corner(1)=ntime + edges(1)=1 + +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px) +#else + ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px) +#endif + if (ierr.ne.NF_NOERR) then + write(*,*) "***** PUT_VAR matter in write_archive" + write(*,*) "***** with ",nom,nf_STRERROR(ierr) + call abort + endif + + endif + + return + end + Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/writerestart.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/writerestart.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/writerestart.F (revision 1540) @@ -0,0 +1,494 @@ + SUBROUTINE writerestart(fichnom,tab_cntrl, + . phis,vcov,ucov,teta,masse,q,ps) + + USE IOIPSL + USE infotrac + USE comconst_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + + IMPLICIT NONE + +c======================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF (pour newstart) +c======================================================================= +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "netcdf.inc" +#include "description.h" + +c Arguments: +c ---------- + CHARACTER*(*) fichnom + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + REAL phis(ip1jmp1) + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm),q(ip1jmp1,llm,nqtot) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + +c Local: +c ------ + INTEGER iq,l + INTEGER ierr + character*20 modname + character*80 abort_message + +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_s, idim_sig + INTEGER idim_tim + INTEGER nid,nvarid + + character*30 unites + + +c----------------------------------------------------------------------- +c Creation du fichier: +c----------------------------------------------------------------------- +c + modname='write_restart_ini' + + 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 +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier demarrage dynamique") +c +c Definir les dimensions du fichiers: +c + ierr = NF_DEF_DIM (nid, "index", length, idim_index) + ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s) + ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig) + ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim) +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition +c +c Definir et enregistrer certains champs invariants: +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,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,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient A pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient B pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c +c Coefficients de passage cov. <-> contra. <--> naturel +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif +c +c Geopentiel au sol: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif +c +c Definir les variables pour pouvoir les enregistrer plus tard: +c + ierr = NF_REDEF (nid) ! entrer dans le mode de definition +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid) +#else + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Temps de simulation") + write(unites,200) 1990,1,1 +200 format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00') + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30, + . unites) + +c + dims4(1) = idim_rlonu + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse U") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatv + dims4(3) = idim_s + dims4(4) = idim_tim +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse V") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11, + . "Temperature") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim + DO iq=1,nqtot +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) + ENDDO +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12, + . "C est quoi ?") +c + dims3(1) = idim_rlonv + dims3(2) = idim_rlatu + dims3(3) = idim_tim +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, + . "Pression au sol") +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + +c----------------------------------------------------------------------- +c Ecriture des variables: +c----------------------------------------------------------------------- +c + modname='write_restart' + + ierr = NF_INQ_VARID(nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + print *, NF_STRERROR(ierr) + abort_message='Variable temps n est pas definie' + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,1,0.) +#else + ierr = NF_PUT_VAR1_REAL (nid,nvarid,1,0.) +#endif + + ierr = NF_INQ_VARID(nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ucov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov) +#endif + + ierr = NF_INQ_VARID(nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable vcov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov) +#endif + + ierr = NF_INQ_VARID(nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable teta n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,teta) +#endif + + do iq=1,nqtot + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ENDDO +c + ierr = NF_INQ_VARID(nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable masse n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,masse) +#endif +c + ierr = NF_INQ_VARID(nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ps n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ps) +#endif + + ierr = NF_CLOSE(nid) ! fermer le fichier + +c PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end +c PRINT*,'rad,omeg,g,cpp,kappa', +c , rad,omeg,g,cpp,kappa + + RETURN + END + Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/writerestartphy.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/writerestartphy.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phytitan/writerestartphy.F (revision 1540) @@ -0,0 +1,343 @@ + SUBROUTINE writerestartphy(fichnom,tab_cntrl,klon,klev, + . rlat,rlon, tsol,tsoil, + . albedo, + . solsw, sollw,fder, + . radsol, + . zmea, zstd, zsig, zgam, zthe, zpic, zval, + . t_ancien) + + +c====================================================================== +c Ecriture de l'etat de redemarrage pour la physique (pour newstart) +c====================================================================== + IMPLICIT none +#include "dimensions.h" +#include "netcdf.inc" +#include "dimsoil.h" +c====================================================================== + CHARACTER*13 fichnom + INTEGER length,klon,klev + PARAMETER (length=100) + REAL tab_cntrl(length) + REAL rlat(klon), rlon(klon) + REAL tsol(klon) + REAL tsoil(klon,nsoilmx) + REAL albedo(klon) + real solsw(klon) + real sollw(klon) + real fder(klon) + REAL radsol(klon) + REAL zmea(klon), zstd(klon) + REAL zsig(klon), zgam(klon), zthe(klon) + REAL zpic(klon), zval(klon) + REAL t_ancien(klon,klev) +c + INTEGER nid, nvarid, idim1, idim2, idim3 + INTEGER ierr +c + INTEGER isoil + CHARACTER*2 str2 +c +c----------------------------------------------------------------------- +c Creation du fichier: +c----------------------------------------------------------------------- +c +c print*,'fichnom',fichnom + 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 redemarrage 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 + +#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----------------------------------------------------------------------- +c Ecriture des variables: +c----------------------------------------------------------------------- +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", 22, + . "Temperature de surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsol) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tsol) +#endif +c + DO isoil=1, nsoilmx + IF (isoil.LE.99) THEN + WRITE(str2,'(i2.2)') isoil + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "Tsoil"//str2,NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "Tsoil"//str2,NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 24, + . "Temperature du sol No."//str2) + 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)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tsoil(1,isoil)) +#endif + ENDDO +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ALBE",NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ALBE",NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18, + . "albedo de surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,albedo) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,albedo) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "solsw", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "solsw", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32, + . "Rayonnement solaire a la surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,solsw) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,solsw) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "sollw", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "sollw", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 27, + . "Rayonnement IF a la surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sollw) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,sollw) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "fder", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "fder", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14, + . "Derive de flux") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,fder) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,fder) +#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, "ZMEA", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zmea Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zstd Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zsig Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zgam Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zthe Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zpic Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zval Orographie sous-maille") + 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, "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_CLOSE(nid) +c + RETURN + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/conf_dat3d.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/conf_dat3d.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/conf_dat3d.F (revision 1540) @@ -0,0 +1,296 @@ +! +! $Header$ +! +C +C + SUBROUTINE conf_dat3d( title, lons,lats,levs,xd,yd,zd,xf,yf,zf, + , champd , interbar ) +c +c Auteur : P. Le Van +c +c Ce s-pr. configure le champ de donnees 3D 'champd' de telle facon +c qu'on ait - pi a pi en longitude +c qu'on ait pi/2. a - pi/2. en latitude +c et qu'on ait les niveaux verticaux variant du sol vers le ht de l'atmos. +c ( en Pascals ) . +c +c xd et yd sont les longitudes et latitudes initiales +c zd les pressions initiales +c +c xf et yf sont les longitudes et latitudes en sortie , eventuellement +c modifiees pour etre configurees comme ci-dessus . +c zf les pressions en sortie +c +c champd en meme temps le champ initial et final +c +c interbar = .TRUE. si on appelle l'interpo. barycentrique inter_barxy +c sinon , l'interpolation grille_m ( grid_atob ) . +c + + IMPLICIT NONE + +c *** Arguments en entree *** + CHARACTER*(*) :: title + INTEGER lons, lats, levs + REAL xd(lons), yd(lats), zd(levs) + LOGICAL interbar +c +c *** Arguments en sortie *** + REAL xf(lons), yf(lats), zf(levs) + +c *** Arguments en entree et sortie *** + REAL champd(lons,lats,levs) + +c *** Variables locales *** +c + REAL pi,pis2,depi,presmax + LOGICAL radianlon, invlon ,radianlat, invlat, invlev, alloc + REAL rlatmin,rlatmax,oldxd1 + INTEGER i,j,ip180,ind,l + + REAL, ALLOCATABLE :: xtemp(:) + REAL, ALLOCATABLE :: ytemp(:) + REAL, ALLOCATABLE :: ztemp(:) + REAL, ALLOCATABLE :: champf(:,:,:) + + +c WRITE(6,*) ' Conf_dat3d pour ',title + + ALLOCATE(xtemp(lons)) + ALLOCATE(ytemp(lats)) + ALLOCATE(ztemp(levs)) + + DO i = 1, lons + xtemp(i) = xd(i) + ENDDO + DO j = 1, lats + ytemp(j) = yd(j) + ENDDO + DO l = 1, levs + ztemp(l) = zd(l) + ENDDO + + pi = 2. * ASIN(1.) + pis2 = pi/2. + depi = 2. * pi + + IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN + radianlon = .TRUE. + invlon = .FALSE. + ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN + radianlon = .TRUE. + invlon = .TRUE. + ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN + radianlon = .FALSE. + invlon = .FALSE. + ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN + radianlon = .FALSE. + invlon = .TRUE. + ELSE + WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' + , , title + ENDIF + + invlat = .FALSE. + + IF( ytemp(1).LT.ytemp(lats) ) THEN + invlat = .TRUE. + ENDIF + + rlatmin = MIN( ytemp(1), ytemp(lats) ) + rlatmax = MAX( ytemp(1), ytemp(lats) ) + + IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN + radianlat = .TRUE. + ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN + radianlat = .FALSE. + ELSE + WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' + , , title + ENDIF + + IF( .NOT. radianlon ) THEN + DO i = 1, lons + xtemp(i) = xtemp(i) * pi/180. + ENDDO + ENDIF + + IF( .NOT. radianlat ) THEN + DO j = 1, lats + ytemp(j) = ytemp(j) * pi/180. + ENDDO + ENDIF + + + alloc =.FALSE. + + IF ( invlon ) THEN + + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + + DO i = 1 ,lons + xf(i) = xtemp(i) + ENDDO + + DO l = 1, levs + DO j = 1, lats + DO i= 1, lons + champf (i,j,l) = champd (i,j,l) + ENDDO + ENDDO + ENDDO +c +c *** On tourne les longit. pour avoir - pi a + pi **** +c + DO i=1,lons + IF( xf(i).GT. pi ) THEN + GO TO 88 + ENDIF + ENDDO + +88 CONTINUE +c + ip180 = i + + DO i = 1,lons + IF (xf(i).GT. pi) THEN + xf(i) = xf(i) - depi + ENDIF + ENDDO + + DO i= ip180,lons + ind = i-ip180 +1 + xtemp(ind) = xf(i) + ENDDO + + DO i= ind +1,lons + xtemp(i) = xf(i-ind) + ENDDO + +c ..... on tourne les longitudes pour champf .... +c + DO l = 1,levs + DO j = 1,lats + DO i = ip180,lons + ind = i-ip180 +1 + champd (ind,j,l) = champf (i,j,l) + ENDDO + + DO i= ind +1,lons + champd (i,j,l) = champf (i-ind,j,l) + ENDDO + ENDDO + ENDDO + + ENDIF +c +c ***** fin de IF(invlon) **** + + IF ( invlat ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + + DO j = 1, lats + ytemp( lats-j+1 ) = yf(j) + DO i = 1, lons + champd (i,lats-j+1,l) = champf (i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + +c ***** fin de IF(invlat) **** +c +c + IF( interbar ) THEN + oldxd1 = xtemp(1) + DO i = 1, lons -1 + xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) + ENDDO + xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) + + DO j = 1, lats -1 + ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) + ENDDO + ENDIF +c + + invlev = .FALSE. + IF( ztemp(1).LT.ztemp(levs) ) invlev = .TRUE. + + presmax = MAX( ztemp(1), ztemp(levs) ) + IF( presmax.LT.1200. ) THEN + DO l = 1,levs + ztemp(l) = ztemp(l) * 100. + ENDDO + ENDIF + + IF( invlev ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO l = 1,levs + zf(l) = ztemp(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + ENDDO + + DO l = 1,levs + ztemp(levs+1-l) = zf(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champd(i,j,levs+1-l) = champf(i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + + IF(alloc) DEALLOCATE(champf) + + DO i = 1, lons + xf(i) = xtemp(i) + ENDDO + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + DO l = 1, levs + zf(l) = ztemp(l) + ENDDO + + DEALLOCATE(xtemp) + DEALLOCATE(ytemp) + DEALLOCATE(ztemp) + + RETURN + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/ini_archive.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/ini_archive.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/ini_archive.F (revision 1540) @@ -0,0 +1,353 @@ +c======================================================================= + subroutine ini_archive(nid,phis,tab_cntrl_dyn,tab_cntrl_fi) +c======================================================================= +c +c +c Date: 01/1997 +c ---- +c +c Objet: ecriture de l'entete du fichier "start_archive" +c ----- +c +c Proche de iniwrite.F +c +c Arguments: +c --------- +c +c Inputs: +c ------ +c +c nid unite logique du fichier "start_archive" +c phis geopotentiel au sol +c tab_cntrl_dyn tableau des param dynamiques +c tab_cntrl_fi tableau des param physiques +c + +c======================================================================= + + USE control_mod + USE comconst_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "description.h" +#include "netcdf.inc" + +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + +c Local: +c ------ + INTEGER length,l + parameter (length = 100) + REAL tab_cntrl(2*length) ! tableau des parametres du run + INTEGER loop + INTEGER ierr, setvdim, putvdim, putdat, setname,cluvdb + INTEGER setdim + INTEGER ind1,indlast + +c Arguments: +c ---------- + REAL phis(ip1jmp1) + REAL tab_cntrl_dyn(length) + REAL tab_cntrl_fi(length) + +!Mars --------Ajouts----------- +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_llmp1,idim_llm + INTEGER idim_tim + INTEGER nid,nvarid + real sig_s(llm),s(llm) + + pi = 2. * ASIN(1.) + + +c----------------------------------------------------------------------- +c Remplissage du tableau des parametres de controle du RUN +c----------------------------------------------------------------------- + + DO l=1,length + tab_cntrl(l) = tab_cntrl_dyn(l) + tab_cntrl(length+l)= tab_cntrl_fi(l) + ENDDO + +c======================================================================= +c Ecriture NetCDF de l''entete du fichier "start_archive" +c======================================================================= + +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier start_archive") +c +c Definir les dimensions du fichiers: +c +c CHAMPS AJOUTES POUR LA VISUALISATION T,ps, etc... avec Grads ou ferret: + ierr = NF_DEF_DIM (nid,"index", 2*length, idim_index) + ierr = NF_DEF_DIM (nid,"rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid,"rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid,"rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid,"rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid,"sigs", llm, idim_llm) + ierr = NF_DEF_DIM (nid,"sig", llmp1, idim_llmp1) + ierr = NF_DEF_DIM (nid,"Time", NF_UNLIMITED, idim_tim) + +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + +c----------------------------------------------------------------------- +c Ecriture du tableau des parametres du run +c----------------------------------------------------------------------- + + call def_var(nid,"Time","Time","days since 00:00:00",1, + . idim_tim,nvarid,ierr) + + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,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----------------------------------------------------------------------- +c Ecriture des longitudes et latitudes +c----------------------------------------------------------------------- + + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif + +c----------------------------------------------------------------------- +c Ecriture des niveaux verticaux +c----------------------------------------------------------------------- + + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_llm,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_llm,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_llmp1,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_llmp1,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_llmp1,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_llmp1,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Coef A: niveaux pression hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_llmp1,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_llmp1,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 35, + . "Coefficient B niveaux sigma hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c +c ---------------------- + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_llm,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_llm,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif + +c----------------------------------------------------------------------- +c Ecriture aire et coefficients de passage cov. <-> contra. <--> naturel +c----------------------------------------------------------------------- + + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif + +c----------------------------------------------------------------------- +c Ecriture du geopentiel au sol +c----------------------------------------------------------------------- + + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif + + RETURN + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/iniphysiq_mod.F90 =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/iniphysiq_mod.F90 (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/iniphysiq_mod.F90 (revision 1540) @@ -0,0 +1,237 @@ +! +! $Id: iniphysiq.F90 2225 2015-03-11 14:55:23Z emillour $ +! +MODULE iniphysiq_mod + +CONTAINS + +SUBROUTINE iniphysiq(iim,jjm,nlayer,punjours, pdayref,ptimestep, & + rlatu,rlatv,rlonu,rlonv,aire,cu,cv, & + prad,pg,pr,pcpp,iflag_phys) + USE dimphy, ONLY: klev ! number of atmospheric levels + USE mod_grid_phy_lmdz, ONLY: klon_glo ! number of atmospheric columns + ! (on full grid) + USE mod_phys_lmdz_para, ONLY: klon_omp, & ! number of columns (on local omp grid) + klon_omp_begin, & ! start index of local omp subgrid + klon_omp_end, & ! end index of local omp subgrid + klon_mpi_begin ! start indes of columns (on local mpi grid) + USE comgeomphy, ONLY: initcomgeomphy, & + airephy, & ! physics grid area (m2) + cuphy, & ! cu coeff. (u_covariant = cu * u) + cvphy, & ! cv coeff. (v_covariant = cv * v) + rlond, & ! longitudes + rlatd ! latitudes + USE temps_mod, ONLY: annee_ref, day_ref, day_ini, day_end + USE time_phylmdz_mod, ONLY: init_time + USE regular_lonlat_mod, ONLY : init_regular_lonlat, & + east, west, north, south, & + north_east, north_west, & + south_west, south_east + USE nrtype, ONLY: pi + IMPLICIT NONE + + ! ======================================================================= + ! Initialisation of the physical constants and some positional and + ! geometrical arrays for the physics + ! ======================================================================= + + include "YOMCST.h" + include "iniprint.h" + + REAL, INTENT (IN) :: prad ! radius of the planet (m) + REAL, INTENT (IN) :: pg ! gravitational acceleration (m/s2) + REAL, INTENT (IN) :: pr ! ! reduced gas constant R/mu + REAL, INTENT (IN) :: pcpp ! specific heat Cp + REAL, INTENT (IN) :: punjours ! length (in s) of a standard day + INTEGER, INTENT (IN) :: nlayer ! number of atmospheric layers + INTEGER, INTENT (IN) :: iim ! number of atmospheric columns along longitudes + INTEGER, INTENT (IN) :: jjm ! number of atompsheric columns along latitudes + REAL, INTENT (IN) :: rlatu(jjm+1) ! latitudes of the physics grid + REAL, INTENT (IN) :: rlatv(jjm) ! latitude boundaries of the physics grid + REAL, INTENT (IN) :: rlonv(iim+1) ! longitudes of the physics grid + REAL, INTENT (IN) :: rlonu(iim+1) ! longitude boundaries of the physics grid + REAL, INTENT (IN) :: aire(iim+1,jjm+1) ! area of the dynamics grid (m2) + REAL, INTENT (IN) :: cu((iim+1)*(jjm+1)) ! cu coeff. (u_covariant = cu * u) + REAL, INTENT (IN) :: cv((iim+1)*jjm) ! cv coeff. (v_covariant = cv * v) + INTEGER, INTENT (IN) :: pdayref ! reference day of for the simulation + REAL, INTENT (IN) :: ptimestep !physics time step (s) + INTEGER, INTENT (IN) :: iflag_phys ! type of physics to be called + + INTEGER :: ibegin, iend, offset + INTEGER :: i,j + CHARACTER (LEN=20) :: modname = 'iniphysiq' + CHARACTER (LEN=80) :: abort_message + REAL :: total_area_phy, total_area_dyn + + ! boundaries, on global grid + REAL,ALLOCATABLE :: boundslon_reg(:,:) + REAL,ALLOCATABLE :: boundslat_reg(:,:) + + ! global array, on full physics grid: + REAL,ALLOCATABLE :: latfi(:) + REAL,ALLOCATABLE :: lonfi(:) + REAL,ALLOCATABLE :: cufi(:) + REAL,ALLOCATABLE :: cvfi(:) + REAL,ALLOCATABLE :: airefi(:) + + IF (nlayer/=klev) THEN + WRITE (lunout, *) 'STOP in ', trim(modname) + WRITE (lunout, *) 'Problem with dimensions :' + WRITE (lunout, *) 'nlayer = ', nlayer + WRITE (lunout, *) 'klev = ', klev + abort_message = '' + CALL abort_gcm(modname, 'Problem with dimensions', 1) + END IF + + !call init_phys_lmdz(iim,jjm+1,llm,1,(/(jjm-1)*iim+2/)) + + ! init regular global longitude-latitude grid points and boundaries + ALLOCATE(boundslon_reg(iim,2)) + ALLOCATE(boundslat_reg(jjm+1,2)) + + DO i=1,iim + boundslon_reg(i,east)=rlonu(i) + boundslon_reg(i,west)=rlonu(i+1) + ENDDO + + boundslat_reg(1,north)= PI/2 + boundslat_reg(1,south)= rlatv(1) + DO j=2,jjm + boundslat_reg(j,north)=rlatv(j-1) + boundslat_reg(j,south)=rlatv(j) + ENDDO + boundslat_reg(jjm+1,north)= rlatv(jjm) + boundslat_reg(jjm+1,south)= -PI/2 + + ! Write values in module regular_lonlat_mod + CALL init_regular_lonlat(iim,jjm+1, rlonv(1:iim), rlatu, & + boundslon_reg, boundslat_reg) + + ! Generate global arrays on full physics grid + ALLOCATE(latfi(klon_glo),lonfi(klon_glo),cufi(klon_glo),cvfi(klon_glo)) + ALLOCATE(airefi(klon_glo)) + + IF (klon_glo>1) THEN ! general case + ! North pole + latfi(1)=rlatu(1) + lonfi(1)=0. + cufi(1) = cu(1) + cvfi(1) = cv(1) + DO j=2,jjm + DO i=1,iim + latfi((j-2)*iim+1+i)= rlatu(j) + lonfi((j-2)*iim+1+i)= rlonv(i) + cufi((j-2)*iim+1+i) = cu((j-1)*(iim+1)+i) + cvfi((j-2)*iim+1+i) = cv((j-1)*(iim+1)+i) + ENDDO + ENDDO + ! South pole + latfi(klon_glo)= rlatu(jjm+1) + lonfi(klon_glo)= 0. + cufi(klon_glo) = cu((iim+1)*jjm+1) + cvfi(klon_glo) = cv((iim+1)*jjm-iim) + + ! build airefi(), mesh area on physics grid + CALL gr_dyn_fi(1,iim+1,jjm+1,klon_glo,aire,airefi) + ! Poles are single points on physics grid + airefi(1)=sum(aire(1:iim,1)) + airefi(klon_glo)=sum(aire(1:iim,jjm+1)) + + ! Sanity check: do total planet area match between physics and dynamics? + total_area_dyn=sum(aire(1:iim,1:jjm+1)) + total_area_phy=sum(airefi(1:klon_glo)) + IF (total_area_dyn/=total_area_phy) THEN + WRITE (lunout, *) 'iniphysiq: planet total surface discrepancy !!!' + WRITE (lunout, *) ' in the dynamics total_area_dyn=', total_area_dyn + WRITE (lunout, *) ' but in the physics total_area_phy=', total_area_phy + IF (abs(total_area_dyn-total_area_phy)>0.00001*total_area_dyn) THEN + ! stop here if the relative difference is more than 0.001% + abort_message = 'planet total surface discrepancy' + CALL abort_gcm(modname, abort_message, 1) + ENDIF + ENDIF + ELSE ! klon_glo==1, running the 1D model + ! just copy over input values + latfi(1)=rlatu(1) + lonfi(1)=rlonv(1) + cufi(1)=cu(1) + cvfi(1)=cv(1) + airefi(1)=aire(1,1) + ENDIF ! of IF (klon_glo>1) + +!$OMP PARALLEL + ! Now generate local lon/lat/cu/cv/area arrays + CALL initcomgeomphy + + offset = klon_mpi_begin - 1 + airephy(1:klon_omp) = airefi(offset+klon_omp_begin:offset+klon_omp_end) + cuphy(1:klon_omp) = cufi(offset+klon_omp_begin:offset+klon_omp_end) + cvphy(1:klon_omp) = cvfi(offset+klon_omp_begin:offset+klon_omp_end) + rlond(1:klon_omp) = lonfi(offset+klon_omp_begin:offset+klon_omp_end) + rlatd(1:klon_omp) = latfi(offset+klon_omp_begin:offset+klon_omp_end) + + ! Initialize some physical constants + call suphec + + ! Initialize some "temporal and calendar" related variables + CALL init_time(annee_ref,day_ref,day_ini,day_end,ptimestep) + +!$OMP END PARALLEL + + ! check that physical constants set in 'suphec' are coherent + ! with values set in the dynamics: + IF (rday/=punjours) THEN + WRITE (lunout, *) 'iniphysiq: length of day discrepancy!!!' + WRITE (lunout, *) ' in the dynamics punjours=', punjours + WRITE (lunout, *) ' but in the physics RDAY=', rday + IF (abs(rday-punjours)>0.01*punjours) THEN + ! stop here if the relative difference is more than 1% + abort_message = 'length of day discrepancy' + CALL abort_gcm(modname, abort_message, 1) + END IF + END IF + + IF (rg/=pg) THEN + WRITE (lunout, *) 'iniphysiq: gravity discrepancy !!!' + WRITE (lunout, *) ' in the dynamics pg=', pg + WRITE (lunout, *) ' but in the physics RG=', rg + IF (abs(rg-pg)>0.01*pg) THEN + ! stop here if the relative difference is more than 1% + abort_message = 'gravity discrepancy' + CALL abort_gcm(modname, abort_message, 1) + END IF + END IF + IF (ra/=prad) THEN + WRITE (lunout, *) 'iniphysiq: planet radius discrepancy !!!' + WRITE (lunout, *) ' in the dynamics prad=', prad + WRITE (lunout, *) ' but in the physics RA=', ra + IF (abs(ra-prad)>0.01*prad) THEN + ! stop here if the relative difference is more than 1% + abort_message = 'planet radius discrepancy' + CALL abort_gcm(modname, abort_message, 1) + END IF + END IF + IF (rd/=pr) THEN + WRITE (lunout, *) 'iniphysiq: reduced gas constant discrepancy !!!' + WRITE (lunout, *) ' in the dynamics pr=', pr + WRITE (lunout, *) ' but in the physics RD=', rd + IF (abs(rd-pr)>0.01*pr) THEN + ! stop here if the relative difference is more than 1% + abort_message = 'reduced gas constant discrepancy' + CALL abort_gcm(modname, abort_message, 1) + END IF + END IF + IF (rcpd/=pcpp) THEN + WRITE (lunout, *) 'iniphysiq: specific heat discrepancy !!!' + WRITE (lunout, *) ' in the dynamics pcpp=', pcpp + WRITE (lunout, *) ' but in the physics RCPD=', rcpd + IF (abs(rcpd-pcpp)>0.01*pcpp) THEN + ! stop here if the relative difference is more than 1% + abort_message = 'specific heat discrepancy' + CALL abort_gcm(modname, abort_message, 1) + END IF + END IF + +END SUBROUTINE iniphysiq + +END MODULE iniphysiq_mod Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/newstart.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/newstart.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/newstart.F (revision 1540) @@ -0,0 +1,1267 @@ +C====================================================================== + PROGRAM newstart +c======================================================================= +c +c +c Auteur: S. Lebonnois, +c a partir des newstart/start_archive/lect_start_archive martiens +c +c Derniere modif : 02/09 (ecriture des q*) +c 01/12 (inclusion dans svn dyn3d) +c +c Objet: Modify the grid for the initial state (LMD GCM VENUS/TITAN) +c ----- (from file NetCDF start_archive.nc) +c +c +c======================================================================= + + use IOIPSL + USE filtreg_mod + USE startvar + USE control_mod + USE infotrac + use cpdet_mod, only: ini_cpdet,t2tpot + use exner_hyb_m, only: exner_hyb + use exner_milieu_m, only: exner_milieu + USE comconst_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + USE serre_mod, ONLY: clon,clat,grossismx,grossismy, + & dzoomx,dzoomy,taux,tauy + USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0 + USE logic_mod, ONLY: iflag_trac,fxyhypb,ysinus + USE temps_mod, ONLY: day_ref,annee_ref + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comdissnew.h" +#include "comgeom2.h" +#include "description.h" +#include "dimsoil.h" +#include "netcdf.inc" + +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + +c Variables pour fichier "ini" +c------------------------------------ + INTEGER imold,jmold,lmold,nqold,ip1jmp1old + INTEGER length + parameter (length = 100) + real tab_cntrl(2*length) + INTEGER isoil,iq,iqmax + CHARACTER*2 str2 + +c Variable histoire +c------------------ + REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants + REAL teta(iip1,jjp1,llm),ps(iip1,jjp1) + REAL phis(iip1,jjp1) ! geopotentiel au sol + REAL masse(ip1jmp1,llm) ! masse de l'atmosphere + REAL, ALLOCATABLE, DIMENSION(:,:,:,:):: q! champs advectes + REAL tab_cntrl_dyn(length) ! tableau des parametres de start + +c variable physique +c------------------ + integer ngridmx + parameter (ngridmx=(2+(jjm-1)*iim - 1/jjm)) + REAL tab_cntrl_fi(length) ! tableau des parametres de startfi + real rlat(ngridmx),rlon(ngridmx) + REAL tsurf(ngridmx),tsoil(ngridmx,nsoilmx) + REAL albe(ngridmx),radsol(ngridmx),sollw(ngridmx) + real solsw(ngridmx),fder(ngridmx) + real sollwdown(ngridmx),dlw(ngridmx) + REAL zmea(ngridmx), zstd(ngridmx) + REAL zsig(ngridmx), zgam(ngridmx), zthe(ngridmx) + REAL zpic(ngridmx), zval(ngridmx) + real t_fi(ngridmx,llm) + +c Variable nouvelle grille naturelle au point scalaire +c------------------------------------------------------ + real us(iip1,jjp1,llm),vs(iip1,jjp1,llm) + REAL p3d(iip1,jjp1,llm+1) ! pression aux interfaces + REAL phisold_newgrid(iip1,jjp1) + REAL T(iip1,jjp1,llm) + real rlonS(iip1,jjp1),rlatS(iip1,jjp1) + real tsurfS(iip1,jjp1),tsoilS(iip1,jjp1,nsoilmx) + real albeS(ip1jmp1),radsolS(ip1jmp1),sollwS(ip1jmp1) + real solswS(ip1jmp1),fderS(ip1jmp1) + real sollwdownS(ip1jmp1),dlwS(ip1jmp1) + real zmeaS(ip1jmp1),zstdS(ip1jmp1),zsigS(ip1jmp1) + real zgamS(ip1jmp1),ztheS(ip1jmp1),zpicS(ip1jmp1) + real zvalS(ip1jmp1) + + real ptotal + +c Var intermediaires : vent naturel, mais pas coord scalaire +c----------------------------------------------------------- + real vnat(iip1,jjm,llm),unat(iip1,jjp1,llm) + + REAL pks(iip1,jjp1) ! exner (f pour filtre) + REAL pk(iip1,jjp1,llm) + REAL pkf(iip1,jjp1,llm) + REAL alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm) + + +c Variable de l'ancienne grille +c--------------------------------------------------------- + + real, dimension(:), allocatable :: rlonuold, rlatvold + real, dimension(:), allocatable :: rlonvold, rlatuold + real, dimension(:), allocatable :: nivsigsold,nivsigold + real, dimension(:), allocatable :: apold,bpold + real, dimension(:), allocatable :: presnivsold + real, dimension(:,:,:), allocatable :: uold,vold,told + real, dimension(:,:,:,:), allocatable :: qold + real, dimension(:,:,:), allocatable :: tsoilold + real, dimension(:,:), allocatable :: psold,phisold + real, dimension(:,:), allocatable :: tsurfold + real, dimension(:,:), allocatable :: albeold,radsolold + real, dimension(:,:), allocatable :: sollwold,solswold + real, dimension(:,:), allocatable :: fderold + real, dimension(:,:), allocatable :: dlwold,sollwdownold + real, dimension(:,:), allocatable :: zmeaold,zstdold,zsigold + real, dimension(:,:), allocatable :: zgamold,ztheold,zpicold + real, dimension(:,:), allocatable :: zvalold + + real ptotalold + +c Variable intermediaires iutilise pour l'extrapolation verticale +c---------------------------------------------------------------- + real, dimension(:,:,:), allocatable :: var,varp1 + +c divers local +c----------------- + + integer ierr,nid,nvarid + INTEGER ij, l,i,j + character*80 fichnom + integer, dimension(4) :: start,counter + REAL phisinverse(iip1,jjp1) ! geopotentiel au sol avant inversion + logical topoflag,notopo,albedoflag,razvitu,razvitv,uini + logical razTS,raztemp + real, dimension(:), allocatable :: tvira,dzst,zkm + real albedo + +c======================================================================= +c INITIALISATIONS DIVERSES +c======================================================================= + +c VENUS/TITAN + + iflag_trac = 1 +c----------------------------------------------------------------------- +c Initialisation des traceurs +c --------------------------- +c Choix du nombre de traceurs et du schema pour l'advection +c dans fichier traceur.def, par default ou via INCA + call infotrac_init + +c Allocation de la tableau q : champs advectes + allocate(q(iip1,jjp1,llm,nqtot)) + +c----------------------------------------------------------------------- +c Ouverture du fichier a modifier (start_archive.nc) +c----------------------------------------------------------------------- + + write(*,*) 'Creation d un etat initial a partir de' + write(*,*) './start_archive.nc' + write(*,*) + fichnom = 'start_archive.nc' + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier ',fichnom + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + +c----------------------------------------------------------------------- +c Lecture du tableau des parametres du run (pour la dynamique) +c----------------------------------------------------------------------- + + write(*,*) 'lecture tab_cntrl START_ARCHIVE' +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif +c + write(*,*) 'Impression de tab_cntrl' + do i=1,200 + write(*,*) i,tab_cntrl(i) + enddo + +c----------------------------------------------------------------------- +c Initialisation des constantes +c----------------------------------------------------------------------- + + imold = tab_cntrl(1) + jmold = tab_cntrl(2) + lmold = tab_cntrl(3) + day_ref = tab_cntrl(4) + annee_ref = tab_cntrl(5) + rad = tab_cntrl(6) + omeg = tab_cntrl(7) + g = tab_cntrl(8) + cpp = tab_cntrl(9) + kappa = tab_cntrl(10) + daysec = tab_cntrl(11) + dtvr = tab_cntrl(12) + etot0 = tab_cntrl(13) + ptot0 = tab_cntrl(14) + ztot0 = tab_cntrl(15) + stot0 = tab_cntrl(16) + ang0 = tab_cntrl(17) + pa = tab_cntrl(18) + preff = tab_cntrl(19) +c + clon = tab_cntrl(20) + clat = tab_cntrl(21) + grossismx = tab_cntrl(22) + grossismy = tab_cntrl(23) + + IF ( tab_cntrl(24).EQ.1. ) THEN + fxyhypb = . TRUE . + dzoomx = tab_cntrl(25) + dzoomy = tab_cntrl(26) + taux = tab_cntrl(28) + tauy = tab_cntrl(29) + ELSE + fxyhypb = . FALSE . + ysinus = . FALSE . + IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. + ENDIF + + ptotalold = tab_cntrl(2*length) + + write(*,*) "Old dimensions:" + write(*,*) "longitude: ",imold + write(*,*) "latitude: ",jmold + write(*,*) "altitude: ",lmold + write(*,*) + + ip1jmp1old = (imold+1-1/imold)*(jmold+1-1/jmold) + +c dans run.def + CALL getin('planet_type',planet_type) + call ini_cpdet + +c======================================================================= +c CHANGEMENT DE CONSTANTES CONTENUES DANS tab_cntrl +c======================================================================= +c changement de la resolution dans le fichier de controle + tab_cntrl(1) = REAL(iim) + tab_cntrl(2) = REAL(jjm) + tab_cntrl(3) = REAL(llm) + +c-------------------------------- +c We use a specific run.def to read new parameters that need to be changed +c-------------------------------- + +c Changement de cpp: + CALL getin('cpp',cpp) + kappa = (8.314511/43.44E-3)/cpp + tab_cntrl(9) = cpp + tab_cntrl(10) = kappa + +c CHANGING THE ZOOM PARAMETERS TO CHANGE THE GRID + CALL getin('clon',clon) + CALL getin('clat',clat) + tab_cntrl(20) = clon + tab_cntrl(21) = clat + CALL getin('grossismx',grossismx) + CALL getin('grossismy',grossismy) + tab_cntrl(22) = grossismx + tab_cntrl(23) = grossismy + CALL getin('fxyhypb',fxyhypb) + IF ( fxyhypb ) THEN + CALL getin('dzoomx',dzoomx) + CALL getin('dzoomy',dzoomy) + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + CALL getin('taux',taux) + CALL getin('tauy',tauy) + tab_cntrl(28) = taux + tab_cntrl(29) = tauy + ELSE + CALL getin('ysinus',ysinus) + IF (ysinus) THEN + tab_cntrl(27) = 1 + ELSE + tab_cntrl(27) = 0 + ENDIF + ENDIF + +c changes must be done BEFORE these lines... + DO l=1,length + tab_cntrl_dyn(l)= tab_cntrl(l) + tab_cntrl_fi(l) = tab_cntrl(l+length) + ENDDO + +c----------------------------------------------------------------------- +c Autres initialisations +c----------------------------------------------------------------------- + + CALL iniconst + CALL inigeom + call inifilr + +c----------------------------------------------------------------------- +c Allocations des anciennes variables +c----------------------------------------------------------------------- + + allocate(rlonuold(imold+1), rlatvold(jmold)) + allocate(rlonvold(imold+1), rlatuold(jmold+1)) + allocate(nivsigsold(lmold+1),nivsigold(lmold)) + allocate(apold(lmold),bpold(lmold)) + allocate(presnivsold(lmold)) + allocate(uold(imold+1,jmold+1,lmold)) + allocate(vold(imold+1,jmold+1,lmold)) + allocate(told(imold+1,jmold+1,lmold)) + allocate(qold(imold+1,jmold+1,lmold,nqtot)) + allocate(psold(imold+1,jmold+1)) + allocate(phisold(imold+1,jmold+1)) + allocate(tsurfold(imold+1,jmold+1)) + allocate(tsoilold(imold+1,jmold+1,nsoilmx)) + allocate(albeold(imold+1,jmold+1),radsolold(imold+1,jmold+1)) + allocate(sollwold(imold+1,jmold+1),solswold(imold+1,jmold+1)) + allocate(fderold(imold+1,jmold+1)) + allocate(sollwdownold(imold+1,jmold+1),dlwold(imold+1,jmold+1)) + allocate(zmeaold(imold+1,jmold+1),zstdold(imold+1,jmold+1)) + allocate(zsigold(imold+1,jmold+1),zgamold(imold+1,jmold+1)) + allocate(ztheold(imold+1,jmold+1),zpicold(imold+1,jmold+1)) + allocate(zvalold(imold+1,jmold+1)) + + allocate(var (imold+1,jmold+1,llm)) + allocate(varp1 (imold+1,jmold+1,llm+1)) + + print*,"Initialisations OK" + +c----------------------------------------------------------------------- +c Lecture des longitudes et latitudes +c----------------------------------------------------------------------- +c + ierr = NF_INQ_VARID (nid, "rlonv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonvold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonvold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "rlatu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatuold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatuold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "rlonu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonuold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonuold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "rlatv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatvold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatvold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + ENDIF +c + + print*,"Lecture lon/lat OK" + +c----------------------------------------------------------------------- +c Lecture des niveaux verticaux +c----------------------------------------------------------------------- +c + ierr = NF_INQ_VARID (nid, "nivsigs", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, nivsigsold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, nivsigsold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "nivsig", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, nivsigold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, nivsigold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ap", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, apold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, apold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + ENDIF + ENDIF +c + ierr = NF_INQ_VARID (nid, "bp", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, bpold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, bpold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + END IF + + ierr = NF_INQ_VARID (nid, "presnivs", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, presnivsold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, presnivsold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + +c----------------------------------------------------------------------- +c Lecture geopotentiel au sol +c----------------------------------------------------------------------- +c + ierr = NF_INQ_VARID (nid, "phisinit", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Le champ est absent de start.nc" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phisold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, phisold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "new_grid: Lecture echouee pour " + CALL abort + ENDIF + + print*,"Lecture niveaux et geopot OK" + +c----------------------------------------------------------------------- +c Lecture des champs 2D () +c----------------------------------------------------------------------- + + start=(/1,1,1,0/) + counter=(/imold+1,jmold+1,1,0/) + + ierr = NF_INQ_VARID (nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,psold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,psold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "tsurf", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,tsurfold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,tsurfold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + do isoil=1,nsoilmx + write(str2,'(i2.2)') isoil +c + ierr = NF_INQ_VARID (nid, "Tsoil"//str2, nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: + . Le champ <","Tsoil"//str2,"> est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter, + . tsoilold(1,1,isoil)) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter, + . tsoilold(1,1,isoil)) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: + . Lecture echouee pour <","Tsoil"//str2,">" + CALL abort + ENDIF + end do +c + ierr = NF_INQ_VARID (nid, "albe", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,albeold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,albeold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "radsol", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,radsolold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,radsolold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "sollw", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,sollwold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,sollwold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "solsw", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,solswold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,solswold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "fder", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,fderold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,fderold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "dlw", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,dlwold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,dlwold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "sollwdown", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,sollwdownold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,sollwdownold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zmea", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zmeaold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zmeaold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zmeaold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zstd", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zstdold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zstdold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zstdold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zsig", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zsigold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zsigold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zsigold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zgam", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zgamold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zgamold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zgamold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zthe", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + ztheold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,ztheold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,ztheold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zpic", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zpicold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zpicold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zpicold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "zval", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, " Il est donc initialise a zero" + zvalold=0. + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,zvalold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,zvalold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + + print*,"Lecture champs 2D OK" + +c----------------------------------------------------------------------- +c Lecture des champs 3D () +c----------------------------------------------------------------------- + + start=(/1,1,1,1/) + counter=(/imold+1,jmold+1,lmold,1/) +c + ierr = NF_INQ_VARID (nid,"temp", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid, start, counter, told) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid, start, counter, told) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid,"u", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,uold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,uold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid,"v", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid, nvarid,start,counter,vold) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,vold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + +c TNAME: IL EST LU A PARTIR DE traceur.def (mettre l'ancien si +c changement du nombre de traceurs) + + IF(iflag_trac.eq.1) THEN + DO iq=1,nqtot + ierr = NF_INQ_VARID (nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent" + PRINT*, " Il est donc initialise a zero" + qold(:,:,:,iq)=0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(nid,nvarid,start,counter,qold(1,1,1,iq)) +#else + ierr = NF_GET_VARA_REAL(nid, nvarid,start,counter,qold(1,1,1,iq)) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour "//tname(iq) + CALL abort + ENDIF + ENDIF + ENDDO + ENDIF + + + print*,"Lecture champs 3D OK" + +c======================================================================= +c INTERPOLATION DANS LA NOUVELLE GRILLE et initialisation des variables +c======================================================================= +c Interpolation horizontale puis passage dans la grille physique pour +c les variables physique +c Interpolation verticale puis horizontale pour chaque variable 3D +c======================================================================= + +c----------------------------------------------------------------------- +c Variable 2d : +c----------------------------------------------------------------------- + +c Relief +! topoflag = F: we keep the existing topography +! = T: we read it from the Relief.nc file +! topoflag need to be in the specific run.def for newstart + topoflag = . FALSE . + CALL getin('topoflag',topoflag) +! notopo = T: we go back to flat surface + notopo = .FALSE. + CALL getin('notopo',notopo) + + print*,zmeaold(2,1:10) + + IF ( topoflag ) then + print*,"Topography (phis) read in file Relief.nc" + print*,"For Venus, map directly inverted in Relief.nc" + CALL startget_phys2d('surfgeo',iip1,jjp1,rlonv,rlatu,phis,0.0, + . jjm ,rlonu,rlatv,.true.) +c needed ? + phis(iip1,:) = phis(1,:) + + CALL startget_phys1d('zmea',iip1,jjp1,rlonv,rlatu,ngridmx,zmea, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zstd',iip1,jjp1,rlonv,rlatu,ngridmx,zstd, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zsig',iip1,jjp1,rlonv,rlatu,ngridmx,zsig, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zgam',iip1,jjp1,rlonv,rlatu,ngridmx,zgam, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zthe',iip1,jjp1,rlonv,rlatu,ngridmx,zthe, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zpic',iip1,jjp1,rlonv,rlatu,ngridmx,zpic, + . 0.0,jjm,rlonu,rlatv,.true.) + CALL startget_phys1d('zval',iip1,jjp1,rlonv,rlatu,ngridmx,zval, + . 0.0,jjm,rlonu,rlatv,.true.) + + ELSE IF ( notopo ) THEN + print*,'Flattening the topography' + phis=0. + zmea=0. + zstd=0. + zsig=0. + zgam=0. + zthe=0. + zpic=0. + zval=0. + ELSE + print*,'Using existing topography' + call interp_horiz (phisold,phis,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + + call interp_horiz (zmeaold,zmeaS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zmeaS,zmea) + call interp_horiz (zstdold,zstdS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zstdS,zstd) + call interp_horiz (zsigold,zsigS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zsigS,zsig) + call interp_horiz (zgamold,zgamS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zgamS,zgam) + call interp_horiz (ztheold,ztheS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,ztheS,zthe) + call interp_horiz (zpicold,zpicS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zpicS,zpic) + call interp_horiz (zvalold,zvalS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,zvalS,zval) + ENDIF + + print*,"New surface geopotential OK" + +c Lat et lon pour physique + do i=1,iip1 + rlatS(i,:)=rlatu(:)*180./pi + enddo + call gr_dyn_fi (1,iip1,jjp1,ngridmx,rlatS,rlat) + + do j=2,jjm + rlonS(:,j)=rlonv(:)*180./pi + enddo + rlonS(:,1)=0. + rlonS(:,jjp1)=0. + call gr_dyn_fi (1,iip1,jjp1,ngridmx,rlonS,rlon) + +c Temperature de surface +! razTS need to be in the specific run.def for newstart + razTS = . FALSE . + CALL getin('razTS',razTS) + + if (razTS) then + tsurf(:) = 735. + else + call interp_horiz (tsurfold,tsurfS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,tsurfS,tsurf) +c write(44,*) 'tsurf', tsurf + endif + +c Temperature du sous-sol + if (razTS) then + tsoil(:,:)=735. + else + call interp_horiz(tsoilold,tsoilS, + & imold,jmold,iim,jjm,nsoilmx, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (nsoilmx,iip1,jjp1,ngridmx,tsoilS,tsoil) +c write(45,*) 'tsoil',tsoil + endif + +! CHANGING ALBEDO: may be done through run.def + albedoflag = . FALSE . + CALL getin('albedoflag',albedoflag) + + IF ( albedoflag ) then + print*,"Albedo is reinitialized to the albedo value in run.def" + print*,"We may want to consider a map later on..." + albedo=0.1 + CALL getin('albedo',albedo) + albe=albedo + ELSE + call interp_horiz (albeold,albeS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,albeS,albe) + ENDIF + + call interp_horiz (radsolold,radsolS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,radsolS,radsol) + + call interp_horiz (sollwold,sollwS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,sollwS,sollw) + + call interp_horiz (solswold,solswS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,solswS,solsw) + + call interp_horiz (fderold,fderS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,fderS,fder) + + call interp_horiz (dlwold,dlwS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,dlwS,dlw) + + call interp_horiz (sollwdownold,sollwdownS,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + call gr_dyn_fi (1,iip1,jjp1,ngridmx,sollwdownS,sollwdown) + + print*,"Nouvelles var physiques OK" + +c----------------------------------------------------------------------- +c Traitement special de la pression au sol : +c----------------------------------------------------------------------- + +c Extrapolation la pression dans la nouvelle grille + call interp_horiz(psold,ps,imold,jmold,iim,jjm,1, + & rlonuold,rlatvold,rlonu,rlatv) + +c On assure la conservation de la masse de l'atmosphere +c-------------------------------------------------------------- + + ptotal = 0. + DO j=1,jjp1 + DO i=1,iim + ptotal=ptotal+ps(i,j)*aire(i,j)/g + END DO + END DO + + write(*,*) + write(*,*)'Ancienne grille: masse de l atm :',ptotalold + write(*,*)'Nouvelle grille: masse de l atm :',ptotal + write (*,*) 'Ratio new atm./ old atm =', ptotal/ptotalold + write(*,*) + + + DO j=1,jjp1 + DO i=1,iip1 + ps(i,j)=ps(i,j) * ptotalold/ptotal + END DO + END DO + +c la pression de surface et les temperatures ne sont pas reequilibrees en fonction +c de la nouvelle topographie... +c Si l'ajustement inevitable du debut pose des problemes, voir le newstart martien. + + print*,"Nouvelle ps OK" + print*,"If changes done on topography, beware !" + print*,"Some time may be needed for adjustments at the beginning" + print*,"so if unstable, relax the timestep and/or dissipation." + +c----------------------------------------------------------------------- +c Variable 3d : +c----------------------------------------------------------------------- + + CALL pression(ip1jmp1, ap, bp, ps, p3d) + if (disvert_type==1) then + CALL exner_hyb( ip1jmp1, ps, p3d,pks, pk, pkf ) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu( ip1jmp1, ps, p3d, pks, pk, pkf ) + endif + +c temperatures atmospheriques + +c ATTENTION: peut servir, mais bon... +c modif: profil uniforme +c do l=1,lmold +c do j=1,jmold+1 +c do i=1,imold+1 +c told(i,j,l)=told(1,jmold/2,l) +c enddo +c enddo +c enddo + +! raztemp need to be in the specific run.def for newstart + raztemp = . FALSE . + CALL getin('raztemp',raztemp) + +! Reinitialisation of temperature to VIRA profile lisse + if (raztemp) then + + allocate(tvira(0:lmold),dzst(0:lmold),zkm(0:lmold)) + print*,"Venus = temperature initiale imposee = VIRA lisse " + dzst(0) = 0.0 + dzst(1) = -log(p3d(1,1,2)/preff)*r/g + do l=2,lmold + dzst(l)=-log(p3d(1,1,l+1)/p3d(1,1,l))*r/g + enddo + tvira(0) = 735. + zkm(0) = 0.0 + do l=1,lmold + zkm(l) = zkm(l-1)+tvira(l-1)*dzst(l)/1000. ! approx avec T(l-1) + if(zkm(l).lt.60.) then + tvira(l)=735.-7.95*zkm(l) + else + tvira(l)=AMAX1(258.-3.*(zkm(l)-60.),168.) + endif + zkm(l) = zkm(l-1)+(tvira(l-1)+tvira(l))/2.*dzst(l)/1000. + enddo + do l=1,lmold + do j=1,jmold+1 + do i=1,imold+1 + told(i,j,l)=tvira(l) + enddo + enddo + enddo + endif ! end raztemp + + write (*,*) 'told ', told (1,jmold+1,1) ! INFO + call interp_vert + & (told,var,lmold,llm,apold,bpold,ap,bp, + & psold,(imold+1)*(jmold+1)) + write (*,*) 'var ', var (1,jmold+1,1) ! INFO + call interp_horiz(var,t,imold,jmold,iim,jjm,llm, + & rlonuold,rlatvold,rlonu,rlatv) + write (*,*) 'T ', T(1,jjp1,1) ! INFO +! pour info: +! Si extension verticale, la T est extrapolee constante au-dessus de lmold + +c passage grille physique pour restartphy.nc + call gr_dyn_fi (llm,iip1,jjp1,ngridmx,T,t_fi) + +! ADAPTATION GCM POUR CP(T) +c passage en temperature potentielle + call t2tpot(ip1jmp1*llm,T,teta,pk) +c on assure la periodicite + teta(iip1,:,:) = teta(1,:,:) + +! RESETING U TO uini: may be done through run.def + uini = .FALSE. + CALL getin('uini',uini) +! RESETING U TO 0: may be done through run.def + razvitu = . FALSE . + CALL getin('razvitu',razvitu) + razvitv = . FALSE . + CALL getin('razvitv',razvitv) + +c calcul des champ de vent; passage en vent covariant + write (*,*) 'uold ', uold (1,2,1) ! INFO + call interp_vert + & (uold,var,lmold,llm,apold,bpold,ap,bp, + & psold,(imold+1)*(jmold+1)) + write (*,*) 'var ', var (1,2,1) ! INFO + call interp_horiz(var,us,imold,jmold,iim,jjm,llm, + & rlonuold,rlatvold,rlonu,rlatv) + write (*,*) 'us ', us (1,2,1) ! INFO + + call interp_vert + & (vold,var,lmold,llm, + & apold,bpold,ap,bp,psold,(imold+1)*(jmold+1)) + call interp_horiz(var,vs,imold,jmold,iim,jjm,llm, + & rlonuold,rlatvold,rlonu,rlatv) + call scal_wind(us,vs,unat,vnat) +! Reseting u=0 + if ((razvitu).and..not.(uini)) then + unat(:,:,:) = 0. + endif +! Reseting u=uini + if ((uini).and..not.(razvitu)) then + do j=1,jjp1 + do l=1,llm + if (p3d(1,j,l).gt.3e3) then + unat(:,j,l) = -110./8.03*log(p3d(:,j,l)/9.2e6) + else + unat(:,j,l) = 110./6.62*(log(p3d(:,j,l)/9.2e6)+14.65) + endif + if (abs(rlatS(1,j)).gt.50.) then + unat(:,j,l)=unat(:,j,l)*(90.-abs(rlatS(:,j)))/40. + endif + enddo + enddo + endif +! incompatible options + if ((uini).and.(razvitu)) then + print*,"You have to choose between razvitu and uini..." + stop + endif + write (*,*) 'unat ', unat (1,2,1) ! INFO + + do l=1,llm + do j = 1, jjp1 + do i=1,iip1 + ucov( i,j,l ) = unat( i,j,l ) * cu(i,j) +! pour info: +! Si extension verticale, on impose u=0 au-dessus de lmold + if (l.gt.lmold) ucov( i,j,l ) = 0 + end do + end do + end do + write (*,*) 'ucov ', ucov (1,2,1) ! INFO +c write(48,*) 'ucov',ucov +! Reseting v=0 + if (razvitv) then + vnat(:,:,:) = 0. + endif + write (*,*) 'vnat ', vnat (1,2,1) ! INFO + do l=1,llm + do j = 1, jjm + do i=1,iim + vcov( i,j,l ) = vnat( i,j,l ) * cv(i,j) +! pour info: +! Si extension verticale, on impose v=0 au-dessus de lmold + if (l.gt.lmold) vcov( i,j,l ) = 0 + end do + vcov( iip1,j,l ) = vcov( 1,j,l ) + end do + end do +c write(49,*) 'ucov',vcov + +c masse: on la recalcule (ps a été ajustée pour conserver la masse totale) + call massdair(p3d,masse) + +c traceurs 3D + do iq = 1, nqtot + call interp_vert(qold(1,1,1,iq),var,lmold,llm, + & apold,bpold,ap,bp,psold,(imold+1)*(jmold+1)) + call interp_horiz(var,q(1,1,1,iq),imold,jmold,iim,jjm,llm, + & rlonuold,rlatvold,rlonu,rlatv) + enddo + + print*,"Nouvelles var dynamiques OK" + +c======================================================================= +c Ecriture des restart.nc et restartphy.nc : +c======================================================================= + + call writerestart('restart.nc',tab_cntrl_dyn, + . phis,vcov,ucov,teta,masse,q,ps) + + print*,"restart OK" + + call writerestartphy('restartphy.nc',tab_cntrl_fi,ngridmx,llm, + . rlat,rlon,tsurf,tsoil,albe,solsw, sollw,fder,dlw, + . sollwdown,radsol, + . zmea,zstd,zsig,zgam,zthe,zpic,zval, + . t_fi) + + print*,"restartphy OK" + + end Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/readstart.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/readstart.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/readstart.F (revision 1540) @@ -0,0 +1,499 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/dynetat0.F,v 1.2 2004/06/22 11:45:30 lmdzadmin Exp $ +! + SUBROUTINE readstart(fichnom,nq,vcov,ucov, + . teta,q,masse,ps,phis,tab_cntrl) + + USE infotrac + USE comconst_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + USE serre_mod, ONLY: clon,clat,grossismx,grossismy + USE ener_mod, ONLY: etot0,ptot0,ztot0,stot0,ang0 + USE temps_mod, ONLY: day_ref,annee_ref,day_ini,itau_dyn, + & start_time + USE logic_mod, ONLY: fxyhypb,ysinus,iflag_trac + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van / L.Fairhead +c ------- +c +c objet: +c ------ +c +c Lecture de l'etat initial +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "description.h" +#include "netcdf.inc" + +c Arguments: +c ---------- + + CHARACTER*(*) fichnom + INTEGER nq + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nq),masse(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL time + INTEGER length + PARAMETER (length=100) + REAL tab_cntrl(length) ! tableau des parametres du run + +c Variables +c + INTEGER iq,i,j,ij,l + INTEGER ierr, nid, nvarid + +c local, cas particulier compo.dat + integer nyread + real qy(jjp1,llm,nq) + character*10 nomy(nq) + +c----------------------------------------------------------------------- + +c Ouverture NetCDF du fichier etat initial + + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start.nc' + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echoue pour " + CALL abort + ENDIF + + im = tab_cntrl(1) + jm = tab_cntrl(2) + lllm = tab_cntrl(3) + day_ref = tab_cntrl(4) + annee_ref = tab_cntrl(5) + rad = tab_cntrl(6) + omeg = tab_cntrl(7) + g = tab_cntrl(8) + cpp = tab_cntrl(9) + kappa = tab_cntrl(10) + daysec = tab_cntrl(11) + dtvr = tab_cntrl(12) + etot0 = tab_cntrl(13) + ptot0 = tab_cntrl(14) + ztot0 = tab_cntrl(15) + stot0 = tab_cntrl(16) + ang0 = tab_cntrl(17) + pa = tab_cntrl(18) + preff = tab_cntrl(19) +c + clon = tab_cntrl(20) + clat = tab_cntrl(21) + grossismx = tab_cntrl(22) + grossismy = tab_cntrl(23) +c + IF ( tab_cntrl(24).EQ.1. ) THEN + fxyhypb = . TRUE . +c dzoomx = tab_cntrl(25) +c dzoomy = tab_cntrl(26) +c taux = tab_cntrl(28) +c tauy = tab_cntrl(29) + ELSE + fxyhypb = . FALSE . + ysinus = . FALSE . + IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. + ENDIF + + day_ini = tab_cntrl(30) + itau_dyn = tab_cntrl(31) + start_time = tab_cntrl(32) +c ................................................................. +c +c + PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa + + IF( im.ne.iim ) THEN + PRINT 1,im,iim + STOP + ELSE IF( jm.ne.jjm ) THEN + PRINT 2,jm,jjm + STOP + ELSE IF( lllm.ne.llm ) THEN + PRINT 3,lllm,llm + STOP + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour rlatv" + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "nivsigs", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, nivsigs) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, nivsigs) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "nivsig", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, nivsig) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, nivsig) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ap", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ap) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ap) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "bp", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, bp) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, bp) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "presnivs", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, presnivs) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, presnivs) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "aire", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, aire) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "phisinit", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, phis) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, time) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ucov) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, vcov) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, teta) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + +c TNAME: IL EST LU A PARTIR DE traceur.def (mettre l'ancien si +c changement du nombre de traceurs) + + IF((nq.GE.1).and.(iflag_trac.eq.1)) THEN + DO iq=1,nq + ierr = NF_INQ_VARID (nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent" + PRINT*, " Il est donc initialise a zero" + q(:,:,iq)=0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq)) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour "//tname(iq) + CALL abort + ENDIF + ENDIF + ENDDO + ENDIF + +c-------------------------------------------- +c cas particulier: lecture des traceurs 2D dans compo.dat (issu de start 2d) +c + if (1.eq.0) then + OPEN(10,file='compo.dat',status='old',form='formatted', + . iostat=ierr) + IF (ierr.ne.0) THEN + WRITE(6,*)' Pb d''ouverture du fichier de demarrage (compo.dat)' + WRITE(6,*)' ierr = ', ierr + CALL exit(1) + ENDIF + READ(10,*) nyread + print*,"nombre de composes chimiques ajoutes:",nyread + READ(10,*) (((qy(ij,l,iq),ij=1,jjp1),l=1,llm), + s iq=1,nyread) + do iq=1,nyread + READ(10,'(1X,A10)') nomy(iq) + print*,nomy(iq)," = ", tname(iq+10) + do i=1,iip1 + do j=1,jjp1 + ij = (j-1)*iip1+i + q(ij,:,iq+10) = qy(j,:,iq) + enddo + enddo + enddo + CLOSE(10) + endif +c-------------------------------------------- + + ierr = NF_INQ_VARID (nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, masse) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ps) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_CLOSE(nid) + + day_ini=day_ini+INT(time) + time=time-INT(time) + + 1 FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree iim =',i4//) + 2 FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree jjm =',i4//) + 3 FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur parametree llm =',i4//) + 4 FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur dtinteg =',i4//) + + RETURN + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/readstartphy.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/readstartphy.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/readstartphy.F (revision 1540) @@ -0,0 +1,528 @@ +! +! $Header: /home/cvsroot/LMDZ4/libf/phylmd/phyetat0.F,v 1.2 2004/06/22 11:45:33 lmdzadmin Exp $ +! +c +c + SUBROUTINE readstartphy(fichnom, + . rlat,rlon, tsol,tsoil, + . albe, solsw, sollw, + . fder,dlw, sollwdown, radsol, + . zmea, zstd, zsig, zgam, zthe, zpic, zval, + . tabcntr0) +c====================================================================== +c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818 +c Objet: Lecture de l'etat initial pour la physique +c====================================================================== + use dimphy + USE mod_grid_phy_lmdz, only: klon_glo + IMPLICIT none +#include "netcdf.inc" +#include "dimsoil.h" +c====================================================================== + + CHARACTER*(*) fichnom + REAL rlat(klon_glo), rlon(klon_glo) + REAL tsol(klon_glo) + REAL tsoil(klon_glo,nsoilmx) + REAL albe(klon_glo) + REAL radsol(klon_glo) + REAL sollw(klon_glo) + real solsw(klon_glo) + real fder(klon_glo) + real dlw(klon_glo) + real sollwdown(klon_glo) + REAL zmea(klon_glo), zstd(klon_glo) + REAL zsig(klon_glo), zgam(klon_glo), zthe(klon_glo) + REAL zpic(klon_glo), zval(klon_glo) + INTEGER length + PARAMETER (length=100) + REAL tabcntr0(length) + + REAL xmin, xmax +c + INTEGER nid, nvarid + INTEGER ierr, i, nsrf, isoil + CHARACTER*2 str2 +c +c Ouvrir le fichier contenant l'etat initial: +c + print*,'fichnom',fichnom + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier '//fichnom + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Lecture des parametres de controle: +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tabcntr0) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tabcntr0) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF +c +c +c Lecture des latitudes (coordonnees): +c + ierr = NF_INQ_VARID (nid, "latitude", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlat) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlat) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF +c +c Lecture des longitudes (coordonnees): +c + ierr = NF_INQ_VARID (nid, "longitude", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlon) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlon) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF +C +c Lecture des temperatures du sol: +c + ierr = NF_INQ_VARID (nid, "TS", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ELSE + PRINT*, 'phyetat0: Le champ est present' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsol) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tsol) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(tsol(i),xmin) + xmax = MAX(tsol(i),xmax) + ENDDO + PRINT*,'Temperature du sol ', xmin, xmax + ENDIF +c +c Lecture des temperatures du sol profond: +c + DO isoil=1, nsoilmx + IF (isoil.GT.99) THEN + PRINT*, "Trop de couches" + CALL abort + ENDIF + WRITE(str2,'(i2.2)') isoil + ierr = NF_INQ_VARID (nid, 'Tsoil'//str2, nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Le champ est absent" + PRINT*, " Il prend donc la valeur de surface" + DO i=1, klon_glo + tsoil(i,isoil)=tsol(i) + ENDDO + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tsoil(1,isoil)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tsoil(1,isoil)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "Lecture echouee pour " + CALL abort + ENDIF + ENDIF + ENDDO + +c +c Lecture de albedo au sol: +c + ierr = NF_INQ_VARID (nid, "ALBE", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ELSE + PRINT*, 'phyetat0: Le champ est present' +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, albe(1)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, albe(1)) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, "phyetat0: Lecture echouee pour " + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(albe(i),xmin) + xmax = MAX(albe(i),xmax) + ENDDO + PRINT*,'Albedo du sol ', xmin, xmax + ENDIF + +c +c Lecture rayonnement solaire au sol: +c + ierr = NF_INQ_VARID (nid, "solsw", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + solsw = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, solsw) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, solsw) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(solsw(i),xmin) + xmax = MAX(solsw(i),xmax) + ENDDO + PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax +c +c Lecture rayonnement IF au sol: +c + ierr = NF_INQ_VARID (nid, "sollw", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + sollw = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, sollw) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, sollw) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(sollw(i),xmin) + xmax = MAX(sollw(i),xmax) + ENDDO + PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax + +c +c Lecture derive des flux: +c + ierr = NF_INQ_VARID (nid, "fder", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + fder = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, fder) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, fder) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(fder(i),xmin) + xmax = MAX(fder(i),xmax) + ENDDO + PRINT*,'Derive des flux fder:', xmin, xmax + +c +c Lecture derive des flux IR: +c + ierr = NF_INQ_VARID (nid, "dlw", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + dlw = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, dlw) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, dlw) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(dlw(i),xmin) + xmax = MAX(dlw(i),xmax) + ENDDO + PRINT*,'Derive des flux IR dlw:', xmin, xmax + +c +c Lecture rayonnement IR vers le bas au sol: +c + ierr = NF_INQ_VARID (nid, "sollwdown", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + sollwdown = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, sollwdown) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, sollwdown) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(sollwdown(i),xmin) + xmax = MAX(sollwdown(i),xmax) + ENDDO + PRINT*,'Flux IR vers le bas au sol sollwdown:', xmin, xmax + +c +c Lecture du rayonnement net au sol: +c + ierr = NF_INQ_VARID (nid, "RADS", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, radsol) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, radsol) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(radsol(i),xmin) + xmax = MAX(radsol(i),xmax) + ENDDO + PRINT*,'Rayonnement net au sol radsol:', xmin, xmax + +c +c Lecture des parametres orographie sous-maille: +c + ierr = NF_INQ_VARID (nid, "ZMEA", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zmea = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zmea) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zmea) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(zmea(i),xmin) + xmax = MAX(zmea(i),xmax) + ENDDO + PRINT*,'zmea:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZSTD", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zstd = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zstd) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zstd) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(zstd(i),xmin) + xmax = MAX(zstd(i),xmax) + ENDDO + PRINT*,'zstd:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZSIG", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zsig = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zsig) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zsig) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(zsig(i),xmin) + xmax = MAX(zsig(i),xmax) + ENDDO + PRINT*,'zsig:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZGAM", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zgam = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zgam) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zgam) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(zgam(i),xmin) + xmax = MAX(zgam(i),xmax) + ENDDO + PRINT*,'zgam:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZTHE", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zthe = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zthe) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zthe) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(zthe(i),xmin) + xmax = MAX(zthe(i),xmax) + ENDDO + PRINT*,'zthe:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZPIC", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zpic = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zpic) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zpic) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(zpic(i),xmin) + xmax = MAX(zpic(i),xmax) + ENDDO + PRINT*,'zpic:', xmin, xmax +c + ierr = NF_INQ_VARID (nid, "ZVAL", nvarid) + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Le champ est absent' + PRINT*, 'mis a zero' + zval = 0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, zval) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, zval) +#endif + IF (ierr.NE.NF_NOERR) THEN + PRINT*, 'phyetat0: Lecture echouee pour ' + CALL abort + ENDIF + ENDIF + xmin = 1.0E+20 + xmax = -1.0E+20 + DO i = 1, klon_glo + xmin = MIN(zval(i),xmin) + xmax = MAX(zval(i),xmax) + ENDDO + PRINT*,'zval:', xmin, xmax +c +c Fermer le fichier: +c + ierr = NF_CLOSE(nid) +c + RETURN + END + Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/scal_wind.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/scal_wind.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/scal_wind.F (revision 1540) @@ -0,0 +1,54 @@ + SUBROUTINE scal_wind(xus,xvs,xu,xv) +c======================================================================= +c +c +c Subject: +c ------ +c On passe les variable xus, xvs aux points de vent u et v (xu et xv) +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" + +c Arguments: +c ---------- + + REAL xu(iip1,jjp1,llm),xv(iip1,jjm,llm) + REAL xus(iip1,jjp1,llm), xvs (iip1,jjp1,llm) + +c Local: +c ------ + + INTEGER i,j,l + +c----------------------------------------------------------------------- + +c transport zonal: +c ---------------- + DO l=1,llm + Do j=1,jjp1 + DO i=1,iim + xu(i,j,l)=0.5*(xus(i,j,l)+xus(i+1,j,l)) + ENDDO + xu(iip1,j,l)=xu(1,j,l) + ENDDO + ENDDO + + +c Transport meridien: +c ------------------- + DO l=1,llm + DO j=1,jjm + do i=1 ,iip1 + xv(i,j,l)=.5*(xvs(i,j,l)+xvs(i,j+1,l)) + end do + ENDDO + ENDDO + + RETURN + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/start2archive.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/start2archive.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/start2archive.F (revision 1540) @@ -0,0 +1,324 @@ +c======================================================================= + PROGRAM start2archive +c======================================================================= +c +c +c Date: 01/1997 +c ---- +c +c Version Venus: 09/2007 +c Titan: 02/2009 +c +c Objet: Passage des fichiers netcdf d etat initial "start" et +c ----- "startphy" a un fichier netcdf unique "start_archive" +c +c======================================================================= + + USE filtreg_mod + USE infotrac + USE control_mod + use cpdet_mod, only: tpot2t,ini_cpdet + use exner_hyb_m, only: exner_hyb + use exner_milieu_m, only: exner_milieu + USE comconst_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + USE logic_mod, ONLY: iflag_trac + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comdissnew.h" +#include "comgeom.h" +#include "description.h" +#include "dimsoil.h" +#include "netcdf.inc" + +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + +c variables dynamiques du GCM +c ----------------------------- + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL, ALLOCATABLE, DIMENSION(:,:,:):: q! champs advectes + REAL pks(ip1jmp1) ! exner (f pour filtre) + REAL pk(ip1jmp1,llm) + REAL pkf(ip1jmp1,llm) + REAL alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm) + REAL phis(ip1jmp1) ! geopotentiel au sol + REAL masse(ip1jmp1,llm) ! masse de l'atmosphere + REAL ps(ip1jmp1) ! pression au sol + REAL p3d(iip1,jjp1,llm+1) ! pression aux interfaces + +c Variable Physiques (grille physique) +c ------------------------------------ + integer ngridmx,nlayermx + parameter (ngridmx=(2+(jjm-1)*iim - 1/jjm)) + parameter (nlayermx=llm) + + real rlat(ngridmx),rlon(ngridmx) + REAL tsurf(ngridmx),tsoil(ngridmx,nsoilmx) + REAL albe(ngridmx),radsol(ngridmx),sollw(ngridmx) + real solsw(ngridmx),fder(ngridmx) + real sollwdown(ngridmx),dlw(ngridmx) + REAL zmea(ngridmx), zstd(ngridmx) + REAL zsig(ngridmx), zgam(ngridmx), zthe(ngridmx) + REAL zpic(ngridmx), zval(ngridmx) + + INTEGER start,length + PARAMETER (length = 100) + REAL tab_cntrl_fi(length) ! tableau des parametres de startfi + REAL tab_cntrl_dyn(length) ! tableau des parametres de start + INTEGER*4 day_ini_fi + +c Variable naturelle / grille scalaire +c ------------------------------------ + REAL T(ip1jmp1,llm),us(ip1jmp1,llm),vs(ip1jmp1,llm) + REAL tsurfS(ip1jmp1),tsoilS(ip1jmp1,nsoilmx) + real rlatS(ip1jmp1),rlonS(ip1jmp1) + real albeS(ip1jmp1),radsolS(ip1jmp1),sollwS(ip1jmp1) + real solswS(ip1jmp1),fderS(ip1jmp1) + real dlwS(ip1jmp1),sollwdownS(ip1jmp1) + real zmeaS(ip1jmp1),zstdS(ip1jmp1),zsigS(ip1jmp1) + real zgamS(ip1jmp1),ztheS(ip1jmp1),zpicS(ip1jmp1) + real zvalS(ip1jmp1) + +c Variables intermediaires : vent naturel, mais pas coord scalaire +c---------------------------------------------------------------- + REAL vn(ip1jm,llm),un(ip1jmp1,llm) + +c Autres variables +c ----------------- + REAL ptotal + + CHARACTER*2 str2 + + INTEGER ij, l,i,j,isoil,iq + character*80 fichnom + integer :: ierr + +c Netcdf +c------- + integer varid,dimid + INTEGER nid + +c----------------------------------------------------------------------- +c Initialisations +c----------------------------------------------------------------------- + +c VENUS/TITAN + + iflag_trac = 1 +c----------------------------------------------------------------------- +c Initialisation des traceurs +c --------------------------- +c Choix du nombre de traceurs et du schema pour l advection +c dans fichier traceur.def, par default ou via INCA + call infotrac_init + +c Allocation de la tableau q : champs advectes + allocate(q(ip1jmp1,llm,nqtot)) + +c======================================================================= +c Lecture des donnees +c======================================================================= + + fichnom = 'start.nc' + CALL readstart(fichnom,nqtot,vcov,ucov,teta,q,masse, + . ps,phis,tab_cntrl_dyn) + + fichnom = 'startphy.nc' + CALL readstartphy(fichnom, + . rlat,rlon,tsurf,tsoil, + . albe, solsw, sollw, + . fder,dlw,sollwdown,radsol, + . zmea,zstd,zsig,zgam,zthe,zpic,zval, + . tab_cntrl_fi) + +c----------------------------------------------------------------------- +c Initialisations +c----------------------------------------------------------------------- + + CALL conf_gcm( 99, .TRUE. ) + call iniconst + call inigeom + call inifilr + call ini_cpdet + + CALL pression(ip1jmp1, ap, bp, ps, p3d) + if (disvert_type==1) then + CALL exner_hyb( ip1jmp1, ps, p3d, pks, pk, pkf ) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu( ip1jmp1, ps, p3d, pks, pk, pkf ) + endif + +c======================================================================= +c Transformation EN VARIABLE NATURELLE / GRILLE SCALAIRE si necessaire +c======================================================================= +c Les variables modeles dependent de la resolution. Il faut donc +c eliminer les facteurs responsables de cette dependance +c (pour utiliser newstart) +c======================================================================= + +c----------------------------------------------------------------------- +c Vent (depend de la resolution horizontale) +c----------------------------------------------------------------------- +c +c ucov --> un et vcov --> vn +c un --> us et vn --> vs +c +c----------------------------------------------------------------------- + + call covnat(llm,ucov, vcov, un, vn) + call wind_scal(un,vn,us,vs) + +c----------------------------------------------------------------------- +c Temperature (depend de la resolution verticale => de "sigma.def") +c----------------------------------------------------------------------- +c +c h --> T +c +c----------------------------------------------------------------------- +! ADAPTATION GCM POUR CP(T) + + call tpot2t(ip1jmp1*llm,teta,T,pk) + +c----------------------------------------------------------------------- +c Variable physique +c----------------------------------------------------------------------- +c +c tsurf --> tsurfS +c et autres... +c +c----------------------------------------------------------------------- + + call gr_fi_dyn(1,ngridmx,iip1,jjp1,tsurf,tsurfS) + call gr_fi_dyn(nsoilmx,ngridmx,iip1,jjp1,tsoil,tsoilS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,rlat,rlatS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,rlon,rlonS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,albe,albeS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,radsol,radsolS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,sollw,sollwS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,solsw,solswS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,fder,fderS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,dlw,dlwS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,sollwdown,sollwdownS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zmea,zmeaS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zstd,zstdS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zsig,zsigS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zgam,zgamS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zthe,ztheS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zpic,zpicS) + call gr_fi_dyn(1,ngridmx,iip1,jjp1,zval,zvalS) + +c======================================================================= +c Info pour controler +c======================================================================= + + ptotal = 0. + DO j=1,jjp1 + DO i=1,iim + ptotal=ptotal+aire(i+(iim+1)*(j-1))*ps(i+(iim+1)*(j-1))/g + ENDDO + ENDDO + write(*,*)'Ancienne grille : masse de l''atm :',ptotal + +c----------------------------------------------------------------------- +c Passage de "ptotal" par tab_cntrl_fi +c----------------------------------------------------------------------- + + tab_cntrl_fi(length) = ptotal + +c======================================================================= +c Ecriture dans le fichier "start_archive" +c======================================================================= + +c----------------------------------------------------------------------- +c Ouverture de "start_archive" +c----------------------------------------------------------------------- + + ierr = NF_OPEN ('start_archive.nc', NF_WRITE,nid) + +c----------------------------------------------------------------------- +c si "start_archive" n'existe pas: +c 1_ ouverture +c 2_ creation de l'entete dynamique ("ini_archive") +c----------------------------------------------------------------------- +c ini_archive: +c On met dans l'entete le tab_cntrl_dyn (1 a length) +c On y ajoute les valeurs du tab_cntrl_fi (length+1 a 2*length) +c----------------------------------------------------------------------- + + if (ierr.ne.NF_NOERR) then + write(*,*)'OK, Could not open file "start_archive.nc"' + write(*,*)'So let s create a new "start_archive"' + ierr = NF_CREATE('start_archive.nc', NF_CLOBBER, nid) + call ini_archive(nid,phis,tab_cntrl_dyn,tab_cntrl_fi) + else + write(*,*)'Attention, start_archive.nc existe déjà...' + call abort + endif + +c----------------------------------------------------------------------- +c Ecriture des champs +c----------------------------------------------------------------------- + + call write_archive(nid,'u','Vent zonal','m.s-1',3,us) + call write_archive(nid,'v','Vent merid','m.s-1',3,vs) + call write_archive(nid,'temp','temperature','K',3,T) +c----------------------------------------------------------------------- +c Ecriture du champs q ( q[1,nqtot] ) +c----------------------------------------------------------------------- + do iq=1,nqtot + write(str2,'(i2.2)') iq + call write_archive(nid,tname(iq),'tracer','kg/kg', + . 3,q(1,1,iq)) + end do +c----------------------------------------------------------------------- + call write_archive(nid,'masse','Masse','kg',3,masse) + call write_archive(nid,'ps','Psurf','Pa',2,ps) + call write_archive(nid,'tsurf','surf T','K',2,tsurfS) +c----------------------------------------------------------------------- +c Ecriture du champs tsoil ( Tsoil[1,nsoilmx] ) +c----------------------------------------------------------------------- +c "tsoil" Temperature au sol definie dans nsoilmx couches dans le sol +c Les nsoilmx couches sont lues comme nsoilmx champs +c nommees Tsoil[1,nsoilmx] + do isoil=1,nsoilmx + write(str2,'(i2.2)') isoil + call write_archive(nid,'Tsoil'//str2,'Ground Temperature ', + . 'K',2,tsoilS(1,isoil)) + enddo +c----------------------------------------------------------------------- + call write_archive(nid,'rlat','Latitude','rad',2,rlatS) + call write_archive(nid,'rlon','Longitude','rad',2,rlonS) + call write_archive(nid,'albe','Albedo','',2,albeS) + call write_archive(nid,'radsol', + . 'Net flux at surface','W m-2',2,radsolS) + call write_archive(nid,'sollw', + . 'LW flux at surface','W m-2',2,sollwS) + call write_archive(nid,'solsw', + . 'SW flux at surface','W m-2',2,solswS) + call write_archive(nid,'fder','derive','?',2,fderS) + call write_archive(nid,'dlw','LW derive','?',2,dlwS) + call write_archive(nid,'sollwdown', + . 'LW dwn flux at surface','?',2,sollwdownS) + call write_archive(nid,'zmea','param oro sous-maille','m',2,zmeaS) + call write_archive(nid,'zstd','param oro sous-maille','m',2,zstdS) + call write_archive(nid,'zsig','param oro sous-maille','m',2,zsigS) + call write_archive(nid,'zgam','param oro sous-maille','m',2,zgamS) + call write_archive(nid,'zthe','param oro sous-maille','m',2,ztheS) + call write_archive(nid,'zpic','param oro sous-maille','m',2,zpicS) + call write_archive(nid,'zval','param oro sous-maille','m',2,zvalS) + + ierr=NF_CLOSE(nid) + +c----------------------------------------------------------------------- +c Fin +c----------------------------------------------------------------------- + + end Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/startvar.F90 =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/startvar.F90 (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/startvar.F90 (revision 1540) @@ -0,0 +1,772 @@ +! +! $Id: startvar.F90 1425 2010-09-02 13:45:23Z lguez $ +! +!******************************************************************************* +! +MODULE startvar +! +!******************************************************************************* +! +!------------------------------------------------------------------------------- +! Purpose: Access data from the database of atmospheric to initialize the model. +!------------------------------------------------------------------------------- +! Comments: +! +! * This module is designed to work for Earth (and with ioipsl) +! +! * There are three ways to acces data, depending on the type of field +! which needs to be extracted. In any case the call should come after a restget +! and should be of the type : CALL startget(...) +! +! - A 1D variable on the physical grid : +! CALL startget_phys1d((varname, iml, jml, lon_in, lat_in, nbindex, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! - A 2D variable on the dynamical grid : +! CALL startget_phys2d(varname, iml, jml, lon_in, lat_in, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! - A 3D variable on the dynamical grid : +! CALL startget_dyn((varname, iml, jml, lon_in, lat_in, lml, pls, workvar, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! * Data needs to be in NetCDF format +! +! * Variables should have the following names in the files: +! 'RELIEF' : High resolution orography +! 'ST' : Surface temperature +! 'CDSW' : Soil moisture +! 'Z' : Surface geopotential +! 'SP' : Surface pressure +! 'U' : East ward wind +! 'V' : Northward wind +! 'TEMP' : Temperature +! 'R' : Relative humidity +! +! * There is a big mess with the longitude size. Should it be iml or iml+1 ? +! I have chosen to use the iml+1 as an argument to this routine and we declare +! internaly smaller fields when needed. This needs to be cleared once and for +! all in LMDZ. A convention is required. +!------------------------------------------------------------------------------- + USE ioipsl + IMPLICIT NONE + + PRIVATE + PUBLIC startget_phys2d, startget_phys1d, startget_dyn +! INTERFACE startget +! MODULE PROCEDURE startget_phys1d, startget_phys2d, startget_dyn +! END INTERFACE + + REAL, SAVE :: deg2rad, pi + INTEGER, SAVE :: iml_rel, jml_rel + INTEGER, SAVE :: fid_phys, iml_phys, jml_phys + INTEGER, SAVE :: fid_dyn, iml_dyn, jml_dyn, llm_dyn, ttm_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lon_phys, lon_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lat_phys, lat_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lon_rug, lon_alb, lon_rel + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lat_rug, lat_alb, lat_rel + REAL, DIMENSION(:), ALLOCATABLE, TARGET, SAVE :: levdyn_ini + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: relief, zstd, zsig, zgam + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: zthe, zpic, zval + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: rugo, phis, tsol, qsol + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: psol_dyn + REAL, DIMENSION(:,:,:), ALLOCATABLE, TARGET, SAVE :: var_ana3d + + CONTAINS + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, lat_in, nbindex, champ, & + val_exp ,jml2, lon_in2, lat_in2, ibar) +! +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: nbindex + REAL, DIMENSION(nbindex), INTENT(INOUT) :: champ + REAL, INTENT(IN) :: val_exp + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(:,:), POINTER :: v2d +!------------------------------------------------------------------------------- + v2d=>NULL() + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + +!--- CHECKING IF THE FIELD IS KNOWN ; READING UNALLOCATED FILES + SELECT CASE(varname) + CASE('tsol') + IF(.NOT.ALLOCATED(tsol)) & + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('qsol') + IF(.NOT.ALLOCATED(qsol)) & + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('psol') + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn (iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('zmea','zstd','zsig','zgam','zthe','zpic','zval') + IF(.NOT.ALLOCATED(relief)) & + CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('rads','snow','tslab','seaice','rugmer','agsno') + CASE DEFAULT + WRITE(lunout,*)'startget_phys1d' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + +!--- SELECTING v2d FOR WANTED VARIABLE AND CHEKING ITS SIZE + SELECT CASE(varname) + CASE('rads','snow','tslab','seaice'); champ=0.0 + CASE('rugmer'); champ(:)=0.001 + CASE('agsno'); champ(:)=50.0 + CASE DEFAULT + SELECT CASE(varname) + CASE('tsol'); v2d=>tsol + CASE('qsol'); v2d=>qsol + CASE('psol'); v2d=>psol_dyn + CASE('zmea'); v2d=>relief + CASE('zstd'); v2d=>zstd + CASE('zsig'); v2d=>zsig + CASE('zgam'); v2d=>zgam + CASE('zthe'); v2d=>zthe + CASE('zpic'); v2d=>zpic + CASE('zval'); v2d=>zval + END SELECT + IF(SIZE(v2d)/=SIZE(lon_in)*SIZE(lat_in)) THEN + WRITE(lunout,*)'STARTVAR module has been initialized to the wrong size' + STOP + END IF + CALL gr_dyn_fi(1,iml,jml,nbindex,v2d,champ) + END SELECT + + ELSE + +!--- SOME FIELDS ARE CAUGHT: MAY BE NEEDED FOR A 3D INTEPROLATION + SELECT CASE(varname) + CASE('tsol') + IF(.NOT.ALLOCATED(tsol)) ALLOCATE(tsol(iml,jml)) + CALL gr_fi_dyn(1,iml,jml,nbindex,champ,tsol) + END SELECT + + END IF + +END SUBROUTINE startget_phys1d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in, champ, val_exp, & + jml2, lon_in2, lat_in2 , ibar) +! +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + REAL, DIMENSION(iml,jml), INTENT(INOUT) :: champ + REAL, INTENT(IN) :: val_exp + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(:,:), POINTER :: v2d=>NULL() +!------------------------------------------------------------------------------- + v2d=>NULL() + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + +!--- CHECKING IF THE FIELD IS KNOWN ; READING UNALLOCATED FILES + SELECT CASE(varname) + CASE('psol') + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn (iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('relief') + IF(.NOT.ALLOCATED(relief)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('surfgeo') + IF(.NOT.ALLOCATED(phis)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('rugosite') + IF(.NOT.ALLOCATED(rugo)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE DEFAULT + WRITE(lunout,*)'startget_phys2d' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + +!--- SELECTING v2d FOR WANTED VARIABLE AND CHEKING ITS SIZE + SELECT CASE(varname) + CASE('psol'); v2d=>psol_dyn + CASE('relief'); v2d=>relief + CASE('rugosite'); v2d=>rugo + CASE('surfgeo'); v2d=>phis + END SELECT + IF(SIZE(champ)/=SIZE(v2d)) THEN + WRITE(lunout,*) 'STARTVAR module has been initialized to the wrong size' + STOP + END IF + + champ(:,:)=v2d(:,:) + + ELSE + +!--- SOME FIELDS ARE CAUGHT: MAY BE NEEDED FOR A 3D INTEPROLATION + SELECT CASE(varname) + CASE ('surfgeo') + IF(.NOT.ALLOCATED(phis)) ALLOCATE(phis(iml,jml)) + IF(SIZE(phis)/=SIZE(champ)) THEN + WRITE(lunout,*)'STARTVAR module has been initialized to the wrong size' + STOP + END IF + phis(:,:)=champ(:,:) + END SELECT + + END IF + +END SUBROUTINE startget_phys2d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_dyn(varname, lon_in, lat_in, pls,workvar,& + champ, val_exp, lon_in2, lat_in2, ibar) + + use assert_eq_m, only: assert_eq + USE comconst_mod + +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + REAL, INTENT(IN) :: lon_in(:) ! dim(iml) + REAL, INTENT(IN) :: lat_in(:) ! dim(jml) + REAL, INTENT(IN) :: pls(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(IN) :: workvar(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(INOUT) :: champ(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(IN) :: val_exp + REAL, INTENT(IN) :: lon_in2(:) ! dim(iml) + REAL, INTENT(IN) :: lat_in2(:) ! dim(jml2) + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + INTEGER :: iml, jml + INTEGER :: lml + INTEGER :: jml2 + REAL, DIMENSION(:,:,:), POINTER :: v3d=>NULL() + CHARACTER(LEN=10) :: vname + INTEGER :: il + REAL :: xppn, xpps +!------------------------------------------------------------------------------- + NULLIFY(v3d) + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + + iml = assert_eq((/size(lon_in), size(pls, 1), size(workvar, 1), & + & size(champ, 1), size(lon_in2)/), "startget_dyn iml") + jml = assert_eq(size(lat_in), size(pls, 2), size(workvar, 2), & + & size(champ, 2), "startget_dyn jml") + lml = assert_eq(size(pls, 3), size(workvar, 3), size(champ, 3), & + & "startget_dyn lml") + jml2 = size(lat_in2) + +!--- READING UNALLOCATED FILES + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + +!--- CHECKING IF THE FIELD IS KNOWN AND INTERPOLATING 3D FIELDS + SELECT CASE(varname) + CASE('u'); vname='U' + CASE('v'); vname='V' + CASE('t','tpot'); vname='TEMP' + CASE('q'); vname='R' + CASE DEFAULT + WRITE(lunout,*)'startget_dyn' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + CALL start_inter_3d(TRIM(vname), iml, jml, lml, lon_in, lat_in, jml2, & + lon_in2, lat_in2, pls, champ,ibar ) + +!--- COMPUTING THE REQUIRED FILED + SELECT CASE(varname) + CASE('u') !--- Eastward wind + DO il=1,lml; champ(:,:,il)=champ(:,:,il)*cu(:,1:jml); END DO + champ(iml,:,:)=champ(1,:,:) + + CASE('v') !--- Northward wind + DO il=1,lml; champ(:,:,il)=champ(:,:,il)*cv(:,1:jml); END DO + champ(iml,:,:)=champ(1,:,:) + + CASE('tpot') !--- Temperature + IF(MINVAL(workvar)/=MAXVAL(workvar)) THEN + champ=champ*cpp/workvar + DO il=1,lml + xppn = SUM(aire(:,1 )*champ(:,1 ,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1 ,il) = xppn + champ(:,jml,il) = xpps + END DO + ELSE + WRITE(lunout,*)'Could not compute potential temperature as the' + WRITE(lunout,*)'Exner function is missing or constant.'; STOP + END IF + + CASE('q') !--- Relat. humidity + IF(MINVAL(workvar)/=MAXVAL(workvar)) THEN + champ=0.01*champ*workvar + WHERE(champ<0.) champ=1.0E-10 + DO il=1,lml + xppn = SUM(aire(:,1 )*champ(:,1 ,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1 ,il) = xppn + champ(:,jml,il) = xpps + END DO + ELSE + WRITE(lunout,*)'Could not compute specific humidity as the' + WRITE(lunout,*)'saturated humidity is missing or constant.'; STOP + END IF + + END SELECT + + END IF + +END SUBROUTINE startget_dyn +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_orog(iml,jml,lon_in,lat_in) + + USE comconst_mod + USE grid_atob_m, ONLY: rugsoro + +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: orofname + LOGICAL :: check=.TRUE. + REAL, DIMENSION(1) :: lev + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: fid, llm_tmp, ttm_tmp + REAL, DIMENSION(:,:), ALLOCATABLE :: relief_hi, tmp_var + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini +!------------------------------------------------------------------------------- + pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + + orofname = 'Relief.nc'; title='RELIEF' + IF(check) WRITE(lunout,*)'Reading the high resolution orography' + CALL flininfo(orofname, iml_rel, jml_rel, llm_tmp, ttm_tmp, fid) + + ALLOCATE(lat_rel(iml_rel,jml_rel),lon_rel(iml_rel,jml_rel)) + CALL flinopen(orofname, .FALSE., iml_rel, jml_rel, llm_tmp, lon_rel, lat_rel,& + lev, ttm_tmp, itau, date, dt, fid) + ALLOCATE(relief_hi(iml_rel,jml_rel)) + CALL flinget(fid, title, iml_rel, jml_rel, llm_tmp, ttm_tmp, 1, 1, relief_hi) + CALL flinclo(fid) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_rel),lat_ini(jml_rel)) + lon_ini(:)=lon_rel(:,1); IF(MAXVAL(lon_rel)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_rel(1,:); IF(MAXVAL(lat_rel)>pi) lat_ini=lat_ini*deg2rad + +!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS + ALLOCATE(lon_rad(iml_rel),lat_rad(jml_rel)) + CALL conf_dat2d(title, iml_rel, jml_rel, lon_ini, lat_ini, lon_rad, lat_rad, & + relief_hi, .FALSE.) + DEALLOCATE(lon_ini,lat_ini) + +!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro + IF(check) WRITE(lunout,*)'Computes all parameters needed for gravity wave dra& + &g code' + + ALLOCATE(phis(iml,jml)) ! Geopotentiel au sol + ALLOCATE(zstd(iml,jml)) ! Deviation standard de l'orographie sous-maille + ALLOCATE(zsig(iml,jml)) ! Pente de l'orographie sous-maille + ALLOCATE(zgam(iml,jml)) ! Anisotropie de l'orographie sous maille + ALLOCATE(zthe(iml,jml)) ! Orientation axe +grande pente d'oro sous maille + ALLOCATE(zpic(iml,jml)) ! Hauteur pics de la SSO + ALLOCATE(zval(iml,jml)) ! Hauteur vallees de la SSO + ALLOCATE(relief(iml,jml)) ! Orographie moyenne + + CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, iml-1, jml, & + lon_in, lat_in, phis, relief, zstd, zsig, zgam, zthe, zpic, zval) + phis = phis * g + +!--- SURFACE ROUGHNESS COMPUTATION (UNUSED FOR THE MOMENT !!! ) + IF(check) WRITE(lunout,*)'Compute surface roughness induced by the orography' + ALLOCATE(rugo (iml ,jml)) + ALLOCATE(tmp_var(iml-1,jml)) + CALL rugsoro(lon_rad, lat_rad, relief_hi, & + lon_in, lat_in, tmp_var) + rugo(1:iml-1,:)=tmp_var; rugo(iml,:)=tmp_var(1,:) + DEALLOCATE(relief_hi,tmp_var,lon_rad,lat_rad) + RETURN + +END SUBROUTINE start_init_orog +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: physfname + LOGICAL :: check=.TRUE. + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: llm_tmp, ttm_tmp + REAL, DIMENSION(:,:), ALLOCATABLE :: var_ana + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(:), ALLOCATABLE :: levphys_ini +!------------------------------------------------------------------------------- + physfname = 'ECPHY.nc'; pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + IF(check) WRITE(lunout,*)'Opening the surface analysis' + CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp, ttm_tmp, fid_phys) + + ALLOCATE(lat_phys(iml_phys,jml_phys)) + ALLOCATE(lon_phys(iml_phys,jml_phys)) + ALLOCATE(levphys_ini(llm_tmp)) + CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, llm_tmp, lon_phys, & + lat_phys, levphys_ini, ttm_tmp, itau, date, dt, fid_phys) + DEALLOCATE(levphys_ini) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_phys),lat_ini(jml_phys)) + lon_ini(:)=lon_phys(:,1); IF(MAXVAL(lon_phys)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_phys(1,:); IF(MAXVAL(lat_phys)>pi) lat_ini=lat_ini*deg2rad + + ALLOCATE(var_ana(iml_phys,jml_phys),lon_rad(iml_phys),lat_rad(jml_phys)) + +!--- SURFACE TEMPERATURE + title='ST' + ALLOCATE(tsol(iml,jml)) + CALL flinget(fid_phys,title,iml_phys,jml_phys,llm_tmp,ttm_tmp,1,1,var_ana) + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, lon_rad, lat_rad,& + var_ana , ibar ) + CALL interp_startvar(title, ibar, .TRUE., & + iml_phys, jml_phys, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, tsol) + +!--- SOIL MOISTURE + title='CDSW' + ALLOCATE(qsol(iml,jml)) + CALL flinget(fid_phys,title,iml_phys,jml_phys,llm_tmp,ttm_tmp,1,1,var_ana) + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, lon_rad, lat_rad,& + var_ana, ibar ) + CALL interp_startvar(title, ibar, .TRUE., & + iml_phys, jml_phys, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, qsol) + + CALL flinclo(fid_phys) + + DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini) + +END SUBROUTINE start_init_phys +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_dyn(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: physfname + LOGICAL :: check=.TRUE. + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: i, j + REAL, DIMENSION(:,:), ALLOCATABLE :: var_ana, z + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(:), ALLOCATABLE :: xppn, xpps +!------------------------------------------------------------------------------- + +!--- KINETIC ENERGY + physfname = 'ECDYN.nc'; pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + IF(check) WRITE(lunout,*) 'Opening the surface analysis' + CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn, ttm_dyn, fid_dyn) + IF(check) WRITE(lunout,*) 'Values read: ', iml_dyn, jml_dyn, llm_dyn, ttm_dyn + + ALLOCATE(lat_dyn(iml_dyn,jml_dyn)) + ALLOCATE(lon_dyn(iml_dyn,jml_dyn)) + ALLOCATE(levdyn_ini(llm_dyn)) + CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn, lon_dyn,lat_dyn,& + levdyn_ini, ttm_dyn, itau, date, dt, fid_dyn) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_dyn),lat_ini(jml_dyn)) + lon_ini(:)=lon_dyn(:,1); IF(MAXVAL(lon_dyn)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_dyn(1,:); IF(MAXVAL(lat_dyn)>pi) lat_ini=lat_ini*deg2rad + + ALLOCATE(var_ana(iml_dyn,jml_dyn),lon_rad(iml_dyn),lat_rad(jml_dyn)) + +!--- SURFACE GEOPOTENTIAL + title='Z' + ALLOCATE(z(iml,jml)) + CALL flinget(fid_dyn, title, iml_dyn, jml_dyn, 0, ttm_dyn, 1, 1, var_ana) + CALL conf_dat2d(title, iml_dyn, jml_dyn, lon_ini, lat_ini, lon_rad, lat_rad, & + var_ana, ibar) + CALL interp_startvar(title, ibar, .TRUE., & + iml_dyn, jml_dyn, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, z) + +!--- SURFACE PRESSURE + title='SP' + ALLOCATE(psol_dyn(iml,jml)) + CALL flinget(fid_dyn, title, iml_dyn, jml_dyn, 0, ttm_dyn, 1, 1, var_ana) + CALL conf_dat2d(title, iml_dyn, jml_dyn, lon_ini, lat_ini, lon_rad, lat_rad, & + var_ana, ibar) + CALL interp_startvar(title, ibar, .TRUE., & + iml_dyn, jml_dyn, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, psol_dyn) + + DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini) + +!--- ALLOCATION OF VARIABLES CREATED IN OR COMING FROM RESTART FILE + IF(.NOT.ALLOCATED(tsol)) THEN + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + ELSE + IF(SIZE(tsol)/=SIZE(psol_dyn)) THEN + WRITE(lunout,*)'start_init_dyn :' + WRITE(lunout,*)'The temperature field we have does not have the right size' + STOP + END IF + END IF + + IF(.NOT.ALLOCATED(phis)) THEN + CALL start_init_orog(iml,jml,lon_in,lat_in) + ELSE + IF(SIZE(phis)/=SIZE(psol_dyn)) THEN + WRITE(lunout,*)'start_init_dyn :' + WRITE(lunout,*)'The orography field we have does not have the right size' + STOP + END IF + END IF + +!--- PSOL IS COMPUTED IN PASCALS + DO j = 1, jml + DO i = 1, iml-1 + psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j))/287.0/tsol(i,j)) + END DO + psol_dyn(iml,j) = psol_dyn(1,j) + END DO + DEALLOCATE(z) + + ALLOCATE(xppn(iml-1),xpps(iml-1)) + DO i = 1, iml-1 + xppn(i) = aire( i,1) * psol_dyn( i,1) + xpps(i) = aire( i,jml) * psol_dyn( i,jml) + END DO + DO i = 1, iml + psol_dyn(i,1 ) = SUM(xppn)/apoln + psol_dyn(i,jml) = SUM(xpps)/apols + END DO + DEALLOCATE(xppn,xpps) + + RETURN + +END SUBROUTINE start_init_dyn +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in, lat_in, jml2, & + lon_in2, lat_in2, pls_in, var3d, ibar) + + use pchsp_95_m, only: pchsp_95 + use pchfe_95_m, only: pchfe_95 + +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml, lml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + REAL, DIMENSION(iml, jml, lml), INTENT(IN) :: pls_in + REAL, DIMENSION(iml, jml, lml), INTENT(OUT) :: var3d + LOGICAL, INTENT(IN) :: ibar +!---------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + LOGICAL:: check=.TRUE., skip + REAL chmin, chmax + INTEGER ii, ij, il, ierr + integer n_extrap ! number of extrapolated points + REAL, DIMENSION(iml, jml, llm_dyn):: var_tmp3d + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(llm_dyn):: lev_dyn, ax, ay, yder + +!--------------------------------------------------------------------------- + IF(check) WRITE(lunout, *)'Going into flinget to extract the 3D field.' + IF(check) WRITE(lunout, *) fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, & + ttm_dyn + IF(check) WRITE(lunout, *) 'Allocating space for interpolation', iml, jml, & + llm_dyn + + IF(.NOT.ALLOCATED(var_ana3d)) ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn)) + CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, ttm_dyn, 1, 1, & + var_ana3d) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_dyn), lat_ini(jml_dyn)) + lon_ini(:)=lon_dyn(:, 1); IF(MAXVAL(lon_dyn)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_dyn(1, :); IF(MAXVAL(lat_dyn)>pi) lat_ini=lat_ini*deg2rad + +!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS + ALLOCATE(lon_rad(iml_dyn), lat_rad(jml_dyn)) + CALL conf_dat3d (varname, iml_dyn, jml_dyn, llm_dyn, lon_ini, lat_ini, & + levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d, ibar) + DEALLOCATE(lon_ini, lat_ini) + +!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro + DO il=1, llm_dyn + CALL interp_startvar(varname, ibar, il==1, iml_dyn, jml_dyn, lon_rad, & + lat_rad, var_ana3d(:, :, il), iml, jml, jml2, lon_in, lat_in, & + lon_in2, lat_in2, var_tmp3d(:, :, il)) + END DO + DEALLOCATE(lon_rad, lat_rad) + +!--- VERTICAL INTERPOLATION IS PERFORMED FROM TOP OF ATMOSPHERE TO GROUND + ax = lev_dyn(llm_dyn:1:-1) + skip = .false. + n_extrap = 0 + DO ij=1, jml + DO ii=1, iml-1 + ay = var_tmp3d(ii, ij, llm_dyn:1:-1) + yder = pchsp_95(ax, ay, ibeg=2, iend=2, vc_beg=0., vc_end=0.) + CALL pchfe_95(ax, ay, yder, skip, pls_in(ii, ij, lml:1:-1), & + var3d(ii, ij, lml:1:-1), ierr) + if (ierr < 0) stop 1 + n_extrap = n_extrap + ierr + END DO + END DO + if (n_extrap /= 0) then + print *, "start_inter_3d pchfe_95: n_extrap = ", n_extrap + end if + var3d(iml, :, :) = var3d(1, :, :) + + DO il=1, lml + CALL minmax(iml*jml, var3d(1, 1, il), chmin, chmax) + WRITE(lunout, *)' '//TRIM(varname)//' min max l ', il, chmin, chmax + END DO + +END SUBROUTINE start_inter_3d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE interp_startvar(vname, ibar, ibeg, ii, jj, lon, lat, vari, & + i1, j1, j2, lon1, lat1, lon2, lat2, varo) +! +!------------------------------------------------------------------------------- + + USE inter_barxy_m, only: inter_barxy + USE grid_atob_m, only: grille_m + +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: vname + LOGICAL, INTENT(IN) :: ibar, ibeg + INTEGER, INTENT(IN) :: ii, jj + REAL, DIMENSION(ii), INTENT(IN) :: lon + REAL, DIMENSION(jj), INTENT(IN) :: lat + REAL, DIMENSION(ii,jj), INTENT(IN) :: vari + INTEGER, INTENT(IN) :: i1, j1, j2 + REAL, DIMENSION(i1), INTENT(IN) :: lon1 + REAL, DIMENSION(j1), INTENT(IN) :: lat1 + REAL, DIMENSION(i1), INTENT(IN) :: lon2 + REAL, DIMENSION(j2), INTENT(IN) :: lat2 + REAL, DIMENSION(i1,j1), INTENT(OUT) :: varo +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(i1-1,j1) :: vtmp +!------------------------------------------------------------------------------- + IF(ibar) THEN + IF(ibeg) THEN + WRITE(lunout,*) & + '---------------------------------------------------------------' + WRITE(lunout,*) & + '$$$ Utilisation de l interpolation barycentrique pour '//TRIM(vname)//' $$$' + WRITE(lunout,*) & + '---------------------------------------------------------------' + END IF + CALL inter_barxy(lon, lat(:jj-1), vari, lon2(:i1-1), lat2(:j2), vtmp) + ELSE + CALL grille_m (lon, lat, vari, lon1, lat1, vtmp) + END IF + CALL gr_int_dyn(vtmp, varo, i1-1, j1) + +END SUBROUTINE interp_startvar +! +!------------------------------------------------------------------------------- + +END MODULE startvar +! +!******************************************************************************* Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/wind_scal.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/wind_scal.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/wind_scal.F (revision 1540) @@ -0,0 +1,54 @@ + SUBROUTINE wind_scal(pbaru,pbarv,us,vs) +c======================================================================= +c +c +c Subject: +c ------ +c On ramene les flux de masse /vents aux points scalaires. +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" + +c Arguments: +c ---------- + + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL us(ip1jmp1,llm), vs (ip1jmp1,llm) + +c Local: +c ------ + + INTEGER ij,l + +c----------------------------------------------------------------------- + +c transport zonal: +c ---------------- + DO l=1,llm + DO ij=2,ip1jmp1 + us(ij,l)=.5*(pbaru(ij,l)+pbaru(ij-1,l)) + ENDDO + ENDDO + CALL SCOPY(jjp1*llm,us(iip1,1),iip1,us(1,1),iip1) + + +c Transport meridien: +c ------------------- + DO l=1,llm + DO ij=iip2,ip1jm + vs(ij,l)=.5*(pbarv(ij,l)+pbarv(ij-iip1,l)) + ENDDO + DO ij=1,iip1 + vs(ij,l)=0. + vs(ip1jm+ij,l)=0. + ENDDO + ENDDO + + RETURN + END Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/write_archive.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/write_archive.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/write_archive.F (revision 1540) @@ -0,0 +1,198 @@ +c======================================================================= + subroutine write_archive(nid,nom,titre,unite,dim,px) +c======================================================================= +c +c +c Date: 01/1997 +c ---- +c +c Objet: Ecriture de champs sur grille scalaire (iip1*jjp1) +c ----- dans un fichier DRS nomme "start_archive" +c +c Il faut au prealable avoir cree un entete avec un "call ini_archive". +c Ces variables peuvent etre 3d (ex: temperature), 2d (ex: temperature +c de surface), ou 0d (pour un scalaire qui ne depend que du temps) +c (ex: la longitude solaire) +c +c +c Arguments: +c ---------- +c +c Inputs: +c ------ +c +c nid Unite logique du fichier "start_archive" +c nom nom du champ a ecrire dans le fichier "start_archive" +c titre titre de la variable dans le fichier DRS "start_archive" +c unite unite de la variable .... +c dim dimension de la variable a ecrire +c px tableau contenant la variable a ecrire +c +c +c======================================================================= + + USE control_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "description.h" +#include "netcdf.inc" + +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + +c Arguments: + + INTEGER nid,ntime,dim + REAL px(iip1,jjp1,llm) + + CHARACTER*(*) nom, titre, unite + + integer ierr + + +c local + integer, dimension(4) :: edges,corner,id + integer :: varid,i,j,l + + ntime = 1 + +c----------------------------------------------------------------------- +c Ecriture du champs dans le fichier (3 cas) +c----------------------------------------------------------------------- + +!Cas Variable 3D +!--------------- + if (dim.eq.3) then + +! Ecriture du champs + +! nom de la variable + ierr= NF_INQ_VARID(nid,nom,varid) + if (ierr /= NF_NOERR) then +! choix du nom des coordonnees + ierr= NF_INQ_DIMID(nid,"rlonv",id(1)) + ierr= NF_INQ_DIMID(nid,"rlatu",id(2)) + ierr= NF_INQ_DIMID(nid,"sigs",id(3)) + ierr= NF_INQ_DIMID(nid,"Time",id(4)) + +! Creation de la variable si elle n'existait pas + + write (*,*) "=====================" + write (*,*) "creation de ",nom + call def_var(nid,nom,titre,unite,4,id,varid,ierr) + + endif + + corner(1)=1 + corner(2)=1 + corner(3)=1 + corner(4)=ntime + + edges(1)=iip1 + edges(2)=jjp1 + edges(3)=llm + edges(4)=1 +#ifdef NC_DOUBLE + ierr= NF_PUT_VARA_DOUBLE(nid,varid,corner,edges,px) +#else + ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px) +#endif + + if (ierr.ne.NF_NOERR) then + write(*,*) "***** PUT_VAR matter in write_archive" + write(*,*) "***** with ",nom," ",nf_STRERROR(ierr) + call abort + endif + +!Cas Variable 2D +!--------------- + + else if (dim.eq.2) then + +! Ecriture du champs + + ierr= NF_INQ_VARID(nid,nom,varid) + if (ierr /= NF_NOERR) then +! choix du nom des coordonnees + ierr= NF_INQ_DIMID(nid,"rlonv",id(1)) + ierr= NF_INQ_DIMID(nid,"rlatu",id(2)) + ierr= NF_INQ_DIMID(nid,"Time",id(3)) + +! Creation de la variable si elle n'existait pas + + write (*,*) "=====================" + write (*,*) "creation de ",nom + + call def_var(nid,nom,titre,unite,3,id,varid,ierr) + + endif + + corner(1)=1 + corner(2)=1 + corner(3)=ntime + edges(1)=iip1 + edges(2)=jjp1 + edges(3)=1 + + +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px) +#else + ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px) +#endif + + if (ierr.ne.NF_NOERR) then + write(*,*) "***** PUT_VAR matter in write_archive" + write(*,*) "***** with ",nom,nf_STRERROR(ierr) + call abort + endif + + +!Cas Variable 0D (scalaire dependant du temps) +!--------------------------------------------- + + else if (dim.eq.0) then + +! Ecriture du champs + + ierr= NF_INQ_VARID(nid,nom,varid) + if (ierr /= NF_NOERR) then +! choix du nom des coordonnees + ierr= NF_INQ_DIMID(nid,"temps",id(1)) + +! Creation de la variable si elle n'existait pas + + write (*,*) "=====================" + write (*,*) "creation de ",nom + + call def_var(nid,nom,titre,unite,1,id,varid,ierr) + + endif + + corner(1)=ntime + edges(1)=1 + +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE (nid,varid,corner,edges,px) +#else + ierr= NF_PUT_VARA_REAL(nid,varid,corner,edges,px) +#endif + if (ierr.ne.NF_NOERR) then + write(*,*) "***** PUT_VAR matter in write_archive" + write(*,*) "***** with ",nom,nf_STRERROR(ierr) + call abort + endif + + endif + + return + end + Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/writerestart.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/writerestart.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/writerestart.F (revision 1540) @@ -0,0 +1,494 @@ + SUBROUTINE writerestart(fichnom,tab_cntrl, + . phis,vcov,ucov,teta,masse,q,ps) + + USE IOIPSL + USE infotrac + USE comconst_mod + USE comvert_mod, ONLY: ap,bp,presnivs,pa,preff,nivsigs,nivsig, + . aps,bps,scaleheight,pseudoalt, + . disvert_type,pressure_exner + + IMPLICIT NONE + +c======================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF (pour newstart) +c======================================================================= +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "netcdf.inc" +#include "description.h" + +c Arguments: +c ---------- + CHARACTER*(*) fichnom + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + REAL phis(ip1jmp1) + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm),q(ip1jmp1,llm,nqtot) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + +c Local: +c ------ + INTEGER iq,l + INTEGER ierr + character*20 modname + character*80 abort_message + +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_s, idim_sig + INTEGER idim_tim + INTEGER nid,nvarid + + character*30 unites + + +c----------------------------------------------------------------------- +c Creation du fichier: +c----------------------------------------------------------------------- +c + modname='write_restart_ini' + + 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 +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier demarrage dynamique") +c +c Definir les dimensions du fichiers: +c + ierr = NF_DEF_DIM (nid, "index", length, idim_index) + ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s) + ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig) + ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim) +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition +c +c Definir et enregistrer certains champs invariants: +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,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,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient A pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient B pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c +c Coefficients de passage cov. <-> contra. <--> naturel +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif +c +c Geopentiel au sol: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif +c +c Definir les variables pour pouvoir les enregistrer plus tard: +c + ierr = NF_REDEF (nid) ! entrer dans le mode de definition +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid) +#else + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Temps de simulation") + write(unites,200) 1990,1,1 +200 format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00') + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30, + . unites) + +c + dims4(1) = idim_rlonu + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse U") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatv + dims4(3) = idim_s + dims4(4) = idim_tim +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse V") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11, + . "Temperature") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim + DO iq=1,nqtot +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) + ENDDO +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12, + . "C est quoi ?") +c + dims3(1) = idim_rlonv + dims3(2) = idim_rlatu + dims3(3) = idim_tim +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, + . "Pression au sol") +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + +c----------------------------------------------------------------------- +c Ecriture des variables: +c----------------------------------------------------------------------- +c + modname='write_restart' + + ierr = NF_INQ_VARID(nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + print *, NF_STRERROR(ierr) + abort_message='Variable temps n est pas definie' + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,1,0.) +#else + ierr = NF_PUT_VAR1_REAL (nid,nvarid,1,0.) +#endif + + ierr = NF_INQ_VARID(nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ucov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov) +#endif + + ierr = NF_INQ_VARID(nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable vcov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov) +#endif + + ierr = NF_INQ_VARID(nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable teta n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,teta) +#endif + + do iq=1,nqtot + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ENDDO +c + ierr = NF_INQ_VARID(nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable masse n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,masse) +#endif +c + ierr = NF_INQ_VARID(nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ps n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ps) +#endif + + ierr = NF_CLOSE(nid) ! fermer le fichier + +c PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end +c PRINT*,'rad,omeg,g,cpp,kappa', +c , rad,omeg,g,cpp,kappa + + RETURN + END + Index: /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/writerestartphy.F =================================================================== --- /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/writerestartphy.F (revision 1540) +++ /trunk/LMDZ.COMMON/libf/dynphy_lonlat/phyvenus/writerestartphy.F (revision 1540) @@ -0,0 +1,375 @@ + SUBROUTINE writerestartphy(fichnom,tab_cntrl,klon,klev, + . rlat,rlon, tsol,tsoil, + . albedo, + . solsw, sollw,fder,dlw, + . sollwdown,radsol, + . zmea, zstd, zsig, zgam, zthe, zpic, zval, + . t_ancien) + + +c====================================================================== +c Ecriture de l'etat de redemarrage pour la physique (pour newstart) +c====================================================================== + IMPLICIT none +#include "dimensions.h" +#include "netcdf.inc" +#include "dimsoil.h" +c====================================================================== + CHARACTER*13 fichnom + INTEGER length,klon,klev + PARAMETER (length=100) + REAL tab_cntrl(length) + REAL rlat(klon), rlon(klon) + REAL tsol(klon) + REAL tsoil(klon,nsoilmx) + REAL albedo(klon) + real solsw(klon) + real sollw(klon) + real fder(klon) + real dlw(klon) + real sollwdown(klon) + REAL radsol(klon) + REAL zmea(klon), zstd(klon) + REAL zsig(klon), zgam(klon), zthe(klon) + REAL zpic(klon), zval(klon) + REAL t_ancien(klon,klev) +c + INTEGER nid, nvarid, idim1, idim2, idim3 + INTEGER ierr +c + INTEGER isoil + CHARACTER*2 str2 +c +c----------------------------------------------------------------------- +c Creation du fichier: +c----------------------------------------------------------------------- +c +c print*,'fichnom',fichnom + 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 redemarrage 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 + +#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----------------------------------------------------------------------- +c Ecriture des variables: +c----------------------------------------------------------------------- +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", 22, + . "Temperature de surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tsol) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tsol) +#endif +c + DO isoil=1, nsoilmx + IF (isoil.LE.99) THEN + WRITE(str2,'(i2.2)') isoil + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "Tsoil"//str2,NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "Tsoil"//str2,NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 24, + . "Temperature du sol No."//str2) + 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)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tsoil(1,isoil)) +#endif + ENDDO +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ALBE",NF_DOUBLE,1,idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ALBE",NF_FLOAT,1,idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 18, + . "albedo de surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,albedo) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,albedo) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "solsw", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "solsw", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 32, + . "Rayonnement solaire a la surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,solsw) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,solsw) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "sollw", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "sollw", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 27, + . "Rayonnement IR a la surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sollw) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,sollw) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "fder", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "fder", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14, + . "Derive de flux") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,fder) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,fder) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "dlw", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "dlw", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14, + . "Derivee flux IR") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,dlw) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,dlw) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "sollwdown", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "sollwdown", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 14, + . "Flux IR vers le bas a la surface") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,sollwdown) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,sollwdown) +#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, "ZMEA", NF_DOUBLE, 1, idim2,nvarid) +#else + ierr = NF_DEF_VAR (nid, "ZMEA", NF_FLOAT, 1, idim2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zmea Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zstd Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zsig Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zgam Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zthe Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zpic Orographie sous-maille") + 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_PUT_ATT_TEXT (nid,nvarid,"title", 28, + . "zval Orographie sous-maille") + 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, "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_CLOSE(nid) +c + RETURN + END Index: /trunk/LMDZ.COMMON/libf/misc/iniprint.h =================================================================== --- /trunk/LMDZ.COMMON/libf/misc/iniprint.h (revision 1540) +++ /trunk/LMDZ.COMMON/libf/misc/iniprint.h (revision 1540) @@ -0,0 +1,11 @@ +! +! $Header$ +! +! +! gestion des impressions de sorties et de débogage +! lunout: unité du fichier dans lequel se font les sorties +! (par defaut 6, la sortie standard) +! prt_level: niveau d'impression souhaité (0 = minimum) +! + INTEGER lunout, prt_level + COMMON /comprint/ lunout, prt_level Index: /trunk/LMDZ.COMMON/makelmdz =================================================================== --- /trunk/LMDZ.COMMON/makelmdz (revision 1539) +++ /trunk/LMDZ.COMMON/makelmdz (revision 1540) @@ -572,9 +572,9 @@ src_dirs="$src_dirs $filtre dyn3d_common dyn3d${FLAG_PARA}" if [[ $physique != "nophys" ]] ; then - src_dirs="$src_dirs dynlonlat_phylonlat dynlonlat_phylonlat/phy${phys_root}" - libdyn_phy="-ldynlonlat_phylonlat" - LIBDYN_PHYS='$(LIBO)/libdynlonlat_phylonlat.a' - INCLUDE="$INCLUDE "'-I$(LIBF)/dynlonlat_phylonlat' - INCLUDE="$INCLUDE "'-I$(LIBF)/dynlonlat_phylonlat/'"${phys_root}" + src_dirs="$src_dirs dynphy_lonlat dynphy_lonlat/phy${phys_root}" + libdyn_phy="-ldynphy_lonlat" + LIBDYN_PHYS='$(LIBO)/libdynphy_lonlat.a' + INCLUDE="$INCLUDE "'-I$(LIBF)/dynphy_lonlat' + INCLUDE="$INCLUDE "'-I$(LIBF)/dynphy_lonlat/'"${phys_root}" fi cd $LIBFGCM/grid @@ -743,8 +743,8 @@ dirmain=phy${physique} else - if [[ -r $LMDGCM/libf/dynlonlat_phylonlat/phy$phys_root/${code}.F ]] + if [[ -r $LMDGCM/libf/dynphy_lonlat/phy$phys_root/${code}.F ]] then source_code=${code}.F - dirmain="dynlonlat_phylonlat/phy${phys_root}" + dirmain="dynphy_lonlat/phy${phys_root}" else if [[ -r $LMDGCM/libf/phy$physique/dyn1d/${code}.F ]] Index: /trunk/LMDZ.COMMON/makelmdz_fcm =================================================================== --- /trunk/LMDZ.COMMON/makelmdz_fcm (revision 1539) +++ /trunk/LMDZ.COMMON/makelmdz_fcm (revision 1540) @@ -36,4 +36,5 @@ job=1 full='' +libphy=false LMDGCM=`/bin/pwd` @@ -192,4 +193,7 @@ full="-full" ; shift ;; + "-libphy") + libphy="true" ; shift ;; + "-arch") arch=$2 ; shift ; shift ;; @@ -264,6 +268,6 @@ PHY_COMMON_PATH="${LIBFGCM}/phy_common" # set the dyn/phys interface path - DYN_PHYS_PATH="${LIBFGCM}/dynlonlat_phylonlat" - DYN_PHYS_SUB_PATH="${LIBFGCM}/dynlonlat_phylonlat/phy${phys_root}" + DYN_PHYS_PATH="${LIBFGCM}/dynphy_lonlat" + DYN_PHYS_SUB_PATH="${LIBFGCM}/dynphy_lonlat/phy${phys_root}" fi @@ -599,4 +603,19 @@ then SUFF_NAME=${SUFF_NAME}_inca +fi + +if [[ $libphy == "true" ]] +then + # special case where we compile only the physics + DYN=$LMDGCM/.void_dir + DYN_COMMON_PATH=$LMDGCM/.void_dir + FILTRE_PATH=$LMDGCM/.void_dir + DYN_PHYS_PATH=$LMDGCM/.void_dir + DYN_PHYS_SUB_PATH=$LMDGCM/.void_dir + #and there is no main program to generate + code="" + SUFF_NAME="" +else + SUFF_NAME=${SUFF_NAME}.e fi @@ -652,5 +671,5 @@ rm -rf config ln -s $LIBOGCM/${arch}${SUFF_NAME}/.config config -ln -s $LIBOGCM/${arch}${SUFF_NAME}/.config/tmp tmp_src +ln -s $LIBOGCM/${arch}${SUFF_NAME}/.config/ppsrc tmp_src Index: /trunk/LMDZ.GENERIC/README =================================================================== --- /trunk/LMDZ.GENERIC/README (revision 1539) +++ /trunk/LMDZ.GENERIC/README (revision 1540) @@ -1185,4 +1185,8 @@ mlayer(k)=lay1_soil*alpha_soil**(k-1/2), for k=0,nsoil-1 - - +== 13/04/2016 == EM +- Some code reorganization: "dynlonlat_phylonlat" directory becomes + "dynphy_lonlat". +- "iniprint.h" moved from "dyn3d" to "misc". + + Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/calfis.F =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/calfis.F (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/calfis.F (revision 1540) @@ -0,0 +1,557 @@ + SUBROUTINE calfis(nq, lafin, rdayvrai,rday_ecri, heure, + $ pucov,pvcov,pteta,pq,pmasse,pps,pp,ppk,pphis,pphi, + $ pducov,pdvcov,pdteta,pdq,pw, + $ pdufi,pdvfi,pdhfi,pdqfi,pdpsfi,tracer ) +c +c Auteur : P. Le Van, F. Hourdin +c ......... + USE infotrac, ONLY: tname, nqtot + USE comvert_mod, ONLY: preff + USE comconst_mod, ONLY: dtphys,kappa,cpp,pi + IMPLICIT NONE +c======================================================================= +c +c 1. rearrangement des tableaux et transformation +c variables dynamiques > variables physiques +c 2. calcul des termes physiques +c 3. retransformation des tendances physiques en tendances dynamiques +c +c remarques: +c ---------- +c +c - les vents sont donnes dans la physique par leurs composantes +c naturelles. +c - la variable thermodynamique de la physique est une variable +c intensive : T +c pour la dynamique on prend T * ( preff / p(l) ) **kappa +c - les deux seules variables dependant de la geometrie necessaires +c pour la physique sont la latitude pour le rayonnement et +c l'aire de la maille quand on veut integrer une grandeur +c horizontalement. +c - les points de la physique sont les points scalaires de la +c la dynamique; numerotation: +c 1 pour le pole nord +c (jjm-1)*iim pour l'interieur du domaine +c ngridmx pour le pole sud +c ---> ngridmx=2+(jjm-1)*iim +c +c Input : +c ------- +c ecritphy frequence d'ecriture (en jours)de histphy +c pucov covariant zonal velocity +c pvcov covariant meridional velocity +c pteta potential temperature +c pps surface pressure +c pmasse masse d'air dans chaque maille +c pts surface temperature (K) +c pw flux vertical (kg/s) +c +c Output : +c -------- +c pdufi tendency for the natural zonal velocity (ms-1) +c pdvfi tendency for the natural meridional velocity +c pdhfi tendency for the potential temperature +c pdtsfi tendency for the surface temperature +c +c tracer Call tracer in gcm.F ? (decided in callphys.def) +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ + +#include "dimensions.h" +#include "paramet.h" + + INTEGER ngridmx,nq + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + +#include "comgeom2.h" +!#include "control.h" + +!#include "advtrac.h" +!! this is to get tnom (tracers name) + +c Arguments : +c ----------- + LOGICAL lafin + REAL heure + + REAL pvcov(iip1,jjm,llm) + REAL pucov(iip1,jjp1,llm) + REAL pteta(iip1,jjp1,llm) + REAL pmasse(iip1,jjp1,llm) + REAL pq(iip1,jjp1,llm,nqtot) + REAL pphis(iip1,jjp1) + REAL pphi(iip1,jjp1,llm) +c + REAL pdvcov(iip1,jjm,llm) + REAL pducov(iip1,jjp1,llm) + REAL pdteta(iip1,jjp1,llm) + REAL pdq(iip1,jjp1,llm,nqtot) +c + REAL pw(iip1,jjp1,llm) +c + REAL pps(iip1,jjp1) + REAL pp(iip1,jjp1,llmp1) + REAL ppk(iip1,jjp1,llm) +c + REAL pdvfi(iip1,jjm,llm) + REAL pdufi(iip1,jjp1,llm) + REAL pdhfi(iip1,jjp1,llm) + REAL pdqfi(iip1,jjp1,llm,nqtot) + REAL pdpsfi(iip1,jjp1) + logical tracer + +c Local variables : +c ----------------- + + INTEGER i,j,l,ig0,ig,iq + REAL zpsrf(ngridmx) + REAL zplev(ngridmx,llm+1),zplay(ngridmx,llm) + REAL zphi(ngridmx,llm),zphis(ngridmx) +c + REAL zufi(ngridmx,llm), zvfi(ngridmx,llm) + REAL ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqtot) +c + REAL zvervel(ngridmx,llm) +c + REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm) + REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqtot) + REAL zdpsrf(ngridmx) +c + REAL zsin(iim),zcos(iim),z1(iim) + REAL zsinbis(iim),zcosbis(iim),z1bis(iim) + REAL unskap, pksurcp +c + + EXTERNAL gr_dyn_fi,gr_fi_dyn + EXTERNAL physiq,multipl + REAL SSUM + EXTERNAL SSUM + + REAL latfi(ngridmx),lonfi(ngridmx) + REAL airefi(ngridmx) + SAVE latfi, lonfi, airefi + + LOGICAL firstcal, debut + DATA firstcal/.true./ + SAVE firstcal,debut + REAL rdayvrai,rday_ecri +c +c----------------------------------------------------------------------- +c +c 1. Initialisations : +c -------------------- +c + + + IF (ngridmx.NE.2+(jjm-1)*iim) THEN + PRINT*,'STOP dans calfis' + PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim' + PRINT*,' ngridmx jjm iim ' + PRINT*,ngridmx,jjm,iim + STOP + ENDIF + +c----------------------------------------------------------------------- +c latitude, longitude et aires des mailles pour la physique: +c ---------------------------------------------------------- + +c + IF ( firstcal ) THEN + debut = .TRUE. + ELSE + debut = .FALSE. + ENDIF + +c +! IF (firstcal) THEN +! latfi(1)=rlatu(1) +! lonfi(1)=0. +! DO j=2,jjm +! DO i=1,iim +! latfi((j-2)*iim+1+i)= rlatu(j) +! lonfi((j-2)*iim+1+i)= rlonv(i) +! ENDDO +! ENDDO +! latfi(ngridmx)= rlatu(jjp1) +! lonfi(ngridmx)= 0. +! +! ! build airefi(), mesh area on physics grid +! CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi) +! ! Poles are single points on physics grid +! airefi(1)=airefi(1)*iim +! airefi(ngridmx)=airefi(ngridmx)*iim +! +! CALL inifis(ngridmx,llm,day_ini,daysec,dtphys, +! . latfi,lonfi,airefi,rad,g,r,cpp) +! ENDIF + +c +c----------------------------------------------------------------------- +c 40. transformation des variables dynamiques en variables physiques: +c --------------------------------------------------------------- + +c 41. pressions au sol (en Pascals) +c ---------------------------------- + + + zpsrf(1) = pps(1,1) + + ig0 = 2 + DO j = 2,jjm + CALL SCOPY( iim,pps(1,j),1,zpsrf(ig0), 1 ) + ig0 = ig0+iim + ENDDO + + zpsrf(ngridmx) = pps(1,jjp1) + + +c 42. pression intercouches : +c +c ----------------------------------------------------------------- +c .... zplev definis aux (llm +1) interfaces des couches .... +c .... zplay definis aux ( llm ) milieux des couches .... +c ----------------------------------------------------------------- + +c ... Exner = cp * ( p(l) / preff ) ** kappa .... +c + unskap = 1./ kappa +c + DO l = 1, llmp1 + zplev( 1,l ) = pp(1,1,l) + ig0 = 2 + DO j = 2, jjm + DO i =1, iim + zplev( ig0,l ) = pp(i,j,l) + ig0 = ig0 +1 + ENDDO + ENDDO + zplev( ngridmx,l ) = pp(1,jjp1,l) + ENDDO +c +c + +c 43. temperature naturelle (en K) et pressions milieux couches . +c --------------------------------------------------------------- + + DO l=1,llm + + pksurcp = ppk(1,1,l) / cpp + zplay(1,l) = preff * pksurcp ** unskap + ztfi(1,l) = pteta(1,1,l) * pksurcp + ig0 = 2 + + DO j = 2, jjm + DO i = 1, iim + pksurcp = ppk(i,j,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap + ztfi(ig0,l) = pteta(i,j,l) * pksurcp + ig0 = ig0 + 1 + ENDDO + ENDDO + + pksurcp = ppk(1,jjp1,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap + ztfi (ig0,l) = pteta(1,jjp1,l) * pksurcp + + ENDDO + + DO l=1, llm + DO ig=1,ngridmx + if (ztfi(ig,l).lt.15) then + write(*,*) 'New Temperature below 15 K !!! ' + write(*,*) 'Stop in calfis.F ' + write(*,*) 'ig=', ig, ' l=', l + write(*,*) 'ztfi(ig,l)=',ztfi(ig,l) + stop + end if + ENDDO + ENDDO + + + +c 43.bis Taceurs (en kg/kg) +c -------------------------- + DO iq=1,nqtot + DO l=1,llm + zqfi(1,l,iq) = pq(1,1,l,iq) + ig0 = 2 + DO j=2,jjm + DO i = 1, iim + zqfi(ig0,l,iq) = pq(i,j,l,iq) + ig0 = ig0 + 1 + ENDDO + ENDDO + zqfi(ig0,l,iq) = pq(1,jjp1,l,iq) + ENDDO + ENDDO + +c Geopotentiel calcule par rapport a la surface locale: +c ----------------------------------------------------- + + CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,pphi,zphi) + CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,pphis,zphis) + DO l=1,llm + DO ig=1,ngridmx + zphi(ig,l)=zphi(ig,l)-zphis(ig) + ENDDO + ENDDO + +c Calcul de la vitesse verticale (m/s) pour diagnostique +c ------------------------------- +c pw est en kg/s +c On interpole "lineairement" la temperature entre les couches(FF,10/95) + +! DO ig=1,ngridmx +! zvervel(ig,1)=0. +! END DO +! DO l=2,llm +! zvervel(1,l)=(pw(1,1,l)/apoln) +! & * r *0.5*(ztfi(1,l)+ztfi(1,l-1)) /zplev(1,l) +! ig0=2 +! DO j=2,jjm +! DO i = 1, iim +! zvervel(ig0,l) = pw(i,j,l) * unsaire(i,j) +! & * r *0.5*(ztfi(ig0,l)+ztfi(ig0,l-1)) /zplev(ig0,l) +! ig0 = ig0 + 1 +! ENDDO +! ENDDO +! zvervel(ig0,l)=(pw(1,jjp1,l)/apols) +! & * r *0.5*(ztfi(ig0,l)+ztfi(ig0,l-1)) /zplev(ig0,l) +! ENDDO + +c ......... Reindexation : calcul de zvervel au MILIEU des couches +! DO l=1,llm-1 +! DO ig=1,ngridmx +! zvervel(ig,l) = 0.5*(zvervel(ig,l)+zvervel(ig,l+1)) +! END DO +! END DO +c (dans la couche llm, on garde la valeur à la limite inférieure llm) + +c 45. champ u: +c ------------ + + DO 50 l=1,llm + + DO 25 j=2,jjm + ig0 = 1+(j-2)*iim + zufi(ig0+1,l)= 0.5 * + $ ( pucov(iim,j,l)/cu(iim,j) + pucov(1,j,l)/cu(1,j) ) + DO 10 i=2,iim + zufi(ig0+i,l)= 0.5 * + $ ( pucov(i-1,j,l)/cu(i-1,j) + pucov(i,j,l)/cu(i,j) ) +10 CONTINUE +25 CONTINUE + +50 CONTINUE + + +c 46.champ v: +c ----------- + + DO l=1,llm + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + zvfi(ig0+i,l)= 0.5 * + $ ( pvcov(i,j-1,l)/cv(i,j-1) + pvcov(i,j,l)/cv(i,j) ) + ENDDO + ENDDO + ENDDO + + +c 47. champs de vents aux pole nord +c ------------------------------ +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1) + z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,1,l)/cv(1,1) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1) + z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,1,l)/cv(i,1) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zcosbis(i)= COS(rlonv(i))*z1bis(i) + zsin(i) = SIN(rlonv(i))*z1(i) + zsinbis(i)= SIN(rlonv(i))*z1bis(i) + ENDDO + + zufi(1,l) = SSUM(iim,zcos,1)/pi + zvfi(1,l) = SSUM(iim,zsin,1)/pi + + ENDDO + + +c 48. champs de vents aux pole sud: +c --------------------------------- +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm) + z1bis(1)=(rlonu(1)-rlonu(iim)+2.*pi)*pdvcov(1,jjm,l)/cv(1,jjm) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm) + z1bis(i)=(rlonu(i)-rlonu(i-1))*pdvcov(i,jjm,l)/cv(i,jjm) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zcosbis(i) = COS(rlonv(i))*z1bis(i) + zsin(i) = SIN(rlonv(i))*z1(i) + zsinbis(i) = SIN(rlonv(i))*z1bis(i) + ENDDO + + zufi(ngridmx,l) = SSUM(iim,zcos,1)/pi + zvfi(ngridmx,l) = SSUM(iim,zsin,1)/pi + + ENDDO + +c----------------------------------------------------------------------- +c Appel de la physique: +c --------------------- + + + CALL physiq (ngridmx,llm,nq, + . tname, + , debut,lafin, + , rday_ecri,heure,dtphys, + , zplev,zplay,zphi, + , zufi, zvfi,ztfi, zqfi, +! , zvervel, + , pw, +C - sorties + s zdufi, zdvfi, zdtfi, zdqfi,zdpsrf,tracer) + + +c----------------------------------------------------------------------- +c transformation des tendances physiques en tendances dynamiques: +c --------------------------------------------------------------- + +c tendance sur la pression : +c ----------------------------------- + + CALL gr_fi_dyn(1,ngridmx,iip1,jjp1,zdpsrf,pdpsfi) +c +ccc CALL multipl(ip1jmp1,aire,pdpsfi,pdpsfi) + +c 62. enthalpie potentielle +c --------------------- + + DO l=1,llm + + DO i=1,iip1 + pdhfi(i,1,l) = cpp * zdtfi(1,l) / ppk(i, 1 ,l) + pdhfi(i,jjp1,l) = cpp * zdtfi(ngridmx,l)/ ppk(i,jjp1,l) + ENDDO + + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + pdhfi(i,j,l) = cpp * zdtfi(ig0+i,l) / ppk(i,j,l) + ENDDO + pdhfi(iip1,j,l) = pdhfi(1,j,l) + ENDDO + + ENDDO + + +c 62. traceurs +c --------------------- + + DO iq=1,nqtot + DO l=1,llm + DO i=1,iip1 + pdqfi(i,1,l,iq) = zdqfi(1,l,iq) + pdqfi(i,jjp1,l,iq) = zdqfi(ngridmx,l,iq) + ENDDO + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + pdqfi(i,j,l,iq) = zdqfi(ig0+i,l,iq) + ENDDO + pdqfi(iip1,j,l,iq) = pdqfi(1,j,l,iq) + ENDDO + ENDDO + ENDDO + +c 65. champ u: +c ------------ + + DO l=1,llm + + DO i=1,iip1 + pdufi(i,1,l) = 0. + pdufi(i,jjp1,l) = 0. + ENDDO + + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim-1 + pdufi(i,j,l)= + $ 0.5*(zdufi(ig0+i,l)+zdufi(ig0+i+1,l))*cu(i,j) + ENDDO + pdufi(iim,j,l)= + $ 0.5*(zdufi(ig0+1,l)+zdufi(ig0+iim,l))*cu(iim,j) + pdufi(iip1,j,l)=pdufi(1,j,l) + ENDDO + + ENDDO + + +c 67. champ v: +c ------------ + + DO l=1,llm + + DO j=2,jjm-1 + ig0=1+(j-2)*iim + DO i=1,iim + pdvfi(i,j,l)= + $ 0.5*(zdvfi(ig0+i,l)+zdvfi(ig0+i+iim,l))*cv(i,j) + ENDDO + pdvfi(iip1,j,l) = pdvfi(1,j,l) + ENDDO + ENDDO + + +c 68. champ v pres des poles: +c --------------------------- +c v = U * cos(long) + V * SIN(long) + + DO l=1,llm + + DO i=1,iim + pdvfi(i,1,l)= + $ zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i)) + pdvfi(i,jjm,l)=zdufi(ngridmx,l)*COS(rlonv(i)) + $ +zdvfi(ngridmx,l)*SIN(rlonv(i)) + pdvfi(i,1,l)= + $ 0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1) + pdvfi(i,jjm,l)= + $ 0.5*(pdvfi(i,jjm,l)+zdvfi(ngridmx-iip1+i,l))*cv(i,jjm) + ENDDO + + pdvfi(iip1,1,l) = pdvfi(1,1,l) + pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l) + + ENDDO + +c----------------------------------------------------------------------- + +700 CONTINUE + + firstcal = .FALSE. + + RETURN + END Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/gr_dyn_fi.F =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/gr_dyn_fi.F (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/gr_dyn_fi.F (revision 1540) @@ -0,0 +1,37 @@ + SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi) + + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER j,ifield,ig + EXTERNAL SCOPY + +c----------------------------------------------------------------------- +c calcul: +c ------- + + IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim' +c traitement des poles + CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid) + CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid) + +c traitement des point normaux + DO ifield=1,nfield + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1) + ENDDO + ENDDO + + RETURN + END Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/gr_fi_dyn.F =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/gr_fi_dyn.F (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/gr_fi_dyn.F (revision 1540) @@ -0,0 +1,38 @@ + SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn) + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ifield,ig + EXTERNAL SCOPY + +c----------------------------------------------------------------------- +c calcul: +c ------- + + DO ifield=1,nfield +c traitement des poles + DO i=1,im + pdyn(i,1,ifield)=pfi(1,ifield) + pdyn(i,jm,ifield)=pfi(ngrid,ifield) + ENDDO + +c traitement des point normaux + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1) + pdyn(im,j,ifield)=pdyn(1,j,ifield) + ENDDO + ENDDO + + RETURN + END Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/caldyn0.F =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/caldyn0.F (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/caldyn0.F (revision 1540) @@ -0,0 +1,1 @@ +link ../../dyn3d/caldyn0.F Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/datareadnc.F =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/datareadnc.F (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/datareadnc.F (revision 1540) @@ -0,0 +1,292 @@ +c======================================================================= + SUBROUTINE datareadnc(relief,filename,phisinit,alb,ith, + . zmea,zstd,zsig,zgam,zthe) +c======================================================================= +c +c +c Author: F. Hourdin 01/1997 +c ------- +c +c Object: To read data from Martian surface to use in a GCM +c ------ from NetCDF file "surface.nc" +c +c +c Arguments: +c ---------- +c +c Inputs: +c ------ +c +c Outputs: +c -------- +c +c======================================================================= +c donnees ALBEDO, INERTIE THERMIQUE, RELIEF: +c +c Ces donnees sont au format NetCDF dans le fichier "surface.nc" +c +c 360 valeurs en longitude (de -179.5 a 179.5) +c 180 valeurs en latitudes (de 89.5 a -89.5) +c +c Pour les passer au format de la grille, on utilise "interp_horiz.F" +c +c Il faut donc que ces donnees soient au format grille scalaire +c (imold+1 jmold+1) +c avec passage des coordonnees de la "boite" (rlonu, rlatv) +c +c On prend imd (d pour donnees!) +c imd = 360 avec copie de la 1ere valeur sur la imd+1 +c (rlonud de -179 a -181) +c jmd = 179 +c (rlatvd de 89 a -89) +c======================================================================= + + use datafile_mod, only: datadir, surfdir +! to use 'getin' + USE ioipsl_getincom + USE comconst_mod, ONLY: g,pi + implicit none + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "netcdf.inc" + +c======================================================================= +c Declarations: +C======================================================================= + + INTEGER imd,jmd,imdp1,jmdp1 + parameter (imd=360,jmd=179,imdp1=361,jmdp1=180) + + INTEGER iimp1 + parameter (iimp1=iim+1-1/iim) + + character(len=3),intent(inout) :: relief*3 + character(len=*),intent(in) :: filename ! surface.nc file + real,intent(out) :: phisinit(iimp1*jjp1) ! surface geopotential + real,intent(out) :: alb(iimp1*jjp1) ! albedo + real,intent(out) :: ith(iimp1*jjp1) ! thermal inertia + real,intent(out) :: zmea(imdp1*jmdp1) + real,intent(out) :: zstd(imdp1*jmdp1) + real,intent(out) :: zsig(imdp1*jmdp1) + real,intent(out) :: zgam(imdp1*jmdp1) + real,intent(out) :: zthe(imdp1*jmdp1) + + REAL zdata(imd*jmdp1) + REAL zdataS(imdp1*jmdp1) + REAL pfield(iimp1*jjp1) + + INTEGER ierr + + INTEGER unit,nvarid + + INTEGER i,j,k + + INTEGER klatdat,ngridmixgdat + PARAMETER (klatdat=180,ngridmixgdat=360) + +c on passe une grille en rlonu rlatv et im+1 jm a interp_horiz) + + REAL longitude(imd),latitude(jmdp1) ! Pour lecture des donnees + REAL rlonud(imdp1),rlatvd(jmd) + + CHARACTER*20 string + DIMENSION string(4) +!#include "fxyprim.h" + + pi=2.*ASIN(1.) + +c======================================================================= +c rlonud, rlatvd +c======================================================================= + +c----------------------------------------------------------------------- +c Lecture NetCDF des donnees latitude et longitude +c----------------------------------------------------------------------- + ierr = NF_OPEN (trim(datadir)//'/'//trim(surfdir)//'/'// + & trim(adjustl(filename)), + & NF_NOWRITE,unit) + IF (ierr.NE.NF_NOERR) THEN + ! In ye old days this file was stored in datadir; + ! let's be retro-compatible + ierr = NF_OPEN (trim(datadir)//'/'// + & trim(adjustl(filename)), + & NF_NOWRITE,unit) + + ENDIF + IF (ierr.NE.NF_NOERR) THEN + write(*,*)'Error : cannot open file '//trim(filename) + write(*,*)'(in phystd/datareadnc.F)' + write(*,*)'It should be in :',trim(datadir),'/',trim(surfdir) + write(*,*)'Check that your path to datagcm:',trim(datadir) + write(*,*)' is correct. You can change it in callphys.def with:' + write(*,*)' datadir = /absolute/path/to/datagcm' + write(*,*)'If necessary surface.nc (and other datafiles)' + write(*,*)' can be obtained online on:' + write(*,*)' http://www.lmd.jussieu.fr/~lmdz/planets/'// + & 'LMDZ.GENERIC/datagcm/' + STOP + ENDIF + +c +c Lecture des latitudes (coordonnees): +c + ierr = NF_INQ_VARID (unit, "latitude", nvarid) +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(unit, nvarid, latitude) +#else + ierr = NF_GET_VAR_REAL(unit, nvarid, latitude) +#endif +c +c Lecture des longitudes (coordonnees): +c + ierr = NF_INQ_VARID (unit, "longitude", nvarid) +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(unit, nvarid, longitude) +#else + ierr = NF_GET_VAR_REAL(unit, nvarid, longitude) +#endif + +c----------------------------------------------------------------------- +c Passage au format boites scalaires +c----------------------------------------------------------------------- + +c----------------------------------------------------------------------- +c longitude(imd) --> rlonud(imdp1) +c----------------------------------------------------------------------- + +c Passage en coordonnees boites scalaires et en radian + do i=1,imd + rlonud(i)=(longitude(i)+.5)*pi/180. + enddo + +c Repetition de la valeur im+1 + rlonud(imdp1)=rlonud(1) + 2*pi + +c----------------------------------------------------------------------- +c latitude(jmdp1) --> rlonvd(jmd) +c----------------------------------------------------------------------- + +c Passage en coordonnees boites scalaires et en radian + do j=1,jmd + rlatvd(j)=(latitude(j)-.5)*pi/180. + enddo + +c======================================================================= +c lecture NetCDF de albedo, thermal, relief, zdtm (pour francois Lott) +c======================================================================= + + string(1) = 'albedo' + string(2) = 'thermal' + if (relief.ne.'pla') then + write(*,*) ' La topographie est celle de MOLA' + relief = 'MOL' + string(3) = 'z'//relief + else + string(3) = 'zMOL' ! pour qu''il lise qqchose sur le fichier + ! remise a 0 derriere + endif + string(4) = 'zMOL' ! lecture pour calcul topog. sous-maille + + + DO k=1,4 + write(*,*) 'string',k,string(k) + +c----------------------------------------------------------------------- +c initialisation +c----------------------------------------------------------------------- + pfield(1:iimp1*jjp1)=0 + zdata(1:imd*jmdp1)=0 + zdataS(1:iimp1*jjp1)=0 + +c----------------------------------------------------------------------- +c Lecture NetCDF +c----------------------------------------------------------------------- + + ierr = NF_INQ_VARID (unit, string(k), nvarid) +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(unit, nvarid, zdata) +#else + ierr = NF_GET_VAR_REAL(unit, nvarid, zdata) +#endif + +c----------------------------------------------------------------------- +c Cas particulier "Francois Lott" ( k=4 ) (relief sous-maille) +c----------------------------------------------------------------------- + if (k.eq.4) then + + zdata(:)=1000.*zdata(:) + longitude(:)=(pi/180.)*longitude(:) + latitude(:)=(pi/180.)*latitude(:) + + call grid_noro1(360, 180, longitude, latitude, zdata, + . iim, jjp1, rlonv, rlatu, zmea,zstd,zsig,zgam,zthe) + + !CALL dump2d(iip1,jjp1,zmea,'zmea') + !CALL dump2d(iip1,jjp1,zstd,'zstd') + !CALL dump2d(iip1,jjp1,zsig,'zsig') + !CALL dump2d(iip1,jjp1,zgam,'zgam') + !CALL dump2d(iip1,jjp1,zthe,'zthe') + + endif + +c----------------------------------------------------------------------- +c Passage de zdata en grille (imdp1 jmdp1) +c----------------------------------------------------------------------- + do j=1,jmdp1 + do i=1,imd + zdataS(i+imdp1*(j-1)) = zdata(i+ngridmixgdat*(j-1)) + enddo + zdataS(imdp1+imdp1*(j-1)) = zdata(1+ngridmixgdat*(j-1)) + enddo + +c----------------------------------------------------------------------- +c Interpolation +c----------------------------------------------------------------------- + call interp_horiz(zdataS,pfield,imd,jmd, + . iim, jjm,1,rlonud,rlatvd,rlonu,rlatv) + +c----------------------------------------------------------------------- +c Periodicite +c----------------------------------------------------------------------- + + do j=1,jjp1 + pfield(iimp1*j) = pfield(1+iimp1*(j-1)) + enddo + +c----------------------------------------------------------------------- +c Sauvegarde des champs +c----------------------------------------------------------------------- + + if (k.eq.1) then ! albedo + do i=1,iimp1*jjp1 + alb(i) = pfield(i) + enddo + elseif (k.eq.2) then ! thermal + do i=1,iimp1*jjp1 + ith(i) = pfield(i) + enddo + elseif (k.eq.3) then ! relief + if (relief.eq.'pla') then + phisinit(1:iimp1*jjp1)=0 + else + phisinit(1:iimp1*jjp1)=pfield(1:iimp1*jjp1) + endif + endif + + ENDDO + +c----------------------------------------------------------------------- +c Traitement Phisinit +c----------------------------------------------------------------------- + + phisinit(1:iimp1*jjp1)=1000.*phisinit(1:iimp1*jjp1) + !CALL dump2d(iimp1,jjp1,phisinit,'Altitude en m') + phisinit(:)=g*phisinit(:) + +c----------------------------------------------------------------------- +c FIN +c----------------------------------------------------------------------- + + END Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/defrun_new.F =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/defrun_new.F (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/defrun_new.F (revision 1540) @@ -0,0 +1,1 @@ +link ../../dyn3d/defrun_new.F Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/exner_hyb.F =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/exner_hyb.F (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/exner_hyb.F (revision 1540) @@ -0,0 +1,1 @@ +link ../../dyn3d/exner_hyb.F Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/grid_noro1.F =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/grid_noro1.F (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/grid_noro1.F (revision 1540) @@ -0,0 +1,425 @@ + SUBROUTINE grid_noro1(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, zmea,zstd,zsig,zgam,zthe) +c======================================================================= +c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead) +c +c Calcul des parametres de l'orographie sous-maille necessaires +c au nouveau shema de representation des montagnes meso-echelles +c dans le modele. Les points sont mis sur une grille rectangulaire +c pseudo-physique. Typiquement, il y a iim+1 latitudes incluant +c le pole nord et le pole sud. Il y a jjm+1 longitudes, y compris +c aux poles. Aux poles les champs peuvent ont une valeurs repetee +c jjm+1 fois..... La valeur du champs en jjm+1 (jmar) est celle +c en j=1. +c Les parametres a,b,c,d representent les limites de la region +c de point de grille correspondant a un point decrit precedemment. +c Les moyennes sur ces regions des valeurs calculees a partir de +c l'USN, sont ponderees par un poids, fonction de la surface +c occuppe par ces donnees a l'interieure de la grille du modele. +c Dans la plupart des cas ce poid est le rapport entre la surface +c de la region de point de grille USN et la surface de la region +c de point de grille du modele. +c +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X et Y pour depart +c xdata, ydata: coordonnees X et Y pour depart +c entree: champ d'entree a transformer +c dans ce programme, on assume que les donnees sont les altitudes +c de l'USNavy: imdep=iusn=2160, jmdep=jusn=1080. +c OUTPUT: +c imar, jmar: dimensions X et Y d'arrivee +c x, y: coordonnees X et Y d'arrivee +c les champs de sorties sont sur une grille physique: +c zmea: orographie moyenne +c zstd: deviation standard de l'orographie sous-maille +c zsig: pente de l'orographie sous-maille +c zgam: anisotropy de l'orographie sous maille +c zthe: orientation de l'axe oriente dans la direction +c de plus grande pente de l'orographie sous maille +C======================================================================= +c IMPLICIT INTEGER (I,J) +c IMPLICIT REAL(X,Z) + + USE comconst_mod, ONLY: rad + + implicit none + integer iusn,jusn,iext + parameter(iusn=360,jusn=180,iext=40) +c!-*- include 'param1' +c!-*- include 'comcstfi.h' +#include "dimensions.h" +c!-*- +c!-*- parameter(iim=cols,jjm=rows) + REAL xusn(iusn+2*iext),yusn(jusn+2) + REAL zusn(iusn+2*iext,jusn+2),zusnfi(iusn+2*iext,jusn+2) + +c modif declarations pour implicit none + real zmeanor,zmeasud,zstdnor,zstdsud,zsignor + real zsigsud,zweinor,zweisud + real xk,xl,xm,xw,xp,xq + real zmaxmea,zmaxstd,zmaxsig,zmaxgam,zmaxthe,zminthe + real zbordnor,zbordsud,zbordest,zbordoue,xpi + real zdeltax,zdeltay,zlenx,zleny,weighx,weighy,xincr + integer i,j,ii,jj,ideltax,ihalph + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + + REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1) + REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1) + REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2) + REAL zxtzyusn(iusn+2*iext,jusn+2) + REAL weight(iim+1,jjm+1) + REAL x(imar+1),y(jmar) + REAL zmea(imar+1,jmar),zstd(imar+1,jmar) + REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar) +c + REAL a(2200),b(2200),c(1100),d(1100) +c +c quelques constantes: +c + print *,' parametres de l orographie a l echelle sous maille' + print*,'rad =',rad + print*,'Long et lat entree' + print*,(x(i),i=1,imar+1) + print*,(y(j),j=1,jmar) + print*,'Long et lat donnees' + print*,(xdata(i),i=1,imdep) + print*,(ydata(j),j=1,jmdep) + + xpi=acos(-1.) + zdeltay=2.*xpi/float(jusn)*rad +c +c quelques tests de dimensions: +c + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF + + IF(imdep.ne.iusn.or.jmdep.ne.jusn)then + print *,' imdep ou jmdep mal dimensionnes:',imdep,jmdep + call abort + ENDIF + + IF(imar+1.gt.iim+1.or.jmar.gt.jjm+1)THEN + print *,' imar ou jmar mal dimensionnes:',imar,jmar + call abort + ENDIF +c +C Extension de la base de donnee de l'USN pour faciliter +C les calculs ulterieurs: +c + DO j=1,jusn + yusn(j+1)=ydata(j) + DO i=1,iusn + zusn(i+iext,j+1)=entree(i,j) + xusn(i+iext)=xdata(i) + ENDDO + DO i=1,iext + zusn(i,j+1)=entree(iusn-iext+i,j) + xusn(i)=xdata(iusn-iext+i)-2.*xpi + zusn(iusn+iext+i,j+1)=entree(i,j) + xusn(iusn+iext+i)=xdata(i)+2.*xpi + ENDDO + ENDDO + + yusn(1)=ydata(1)+(ydata(1)-ydata(2)) + yusn(jusn+2)=ydata(jusn)+(ydata(jusn)-ydata(jusn-1)) + DO i=1,iusn/2+iext + zusn(i,1)=zusn(i+iusn/2,2) + zusn(i+iusn/2+iext,1)=zusn(i,2) + zusn(i,jusn+2)=zusn(i+iusn/2,jusn+1) + zusn(i+iusn/2+iext,jusn+2)=zusn(i,jusn+1) + ENDDO +c +c Calcul d'une orographie filtree aux hautes latitudes +c pour permettre des calculs plus isotropiques sur la pente +c des montagnes +c + DO i=1,IUSN+2*iext + DO J=1,JUSN+2 + zusnfi(i,j)=0.0 + ENDDO + ENDDO + + DO j=1,jusn + ideltax=1./cos(yusn(j+1)) + ideltax=min(iusn/2-1,ideltax) + IF(MOD(IDELTAX,2).EQ.0)THEN + IDELTAX=IDELTAX+1 + ENDIF + IHALPH=(IDELTAX-1)/2 +c print *,' ideltax=',ideltax + IF(ideltax.eq.1)THEN + DO i=1,iusn + zusnfi(i+iext,j+1)=entree(i,j) + ENDDO + ELSE + DO i=1,ihalph + DO ii=1,i+ihalph + zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(ii,j) + ENDDO + DO ii=ihalph-i,0,-1 + zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(iusn-ii,j) + ENDDO + zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)/float(ideltax) + ENDDO + DO i=iusn-ihalph+1,iusn + DO ii = i-ihalph,iusn + zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(ii,j) + ENDDO + DO ii = 1,ihalph+i-iusn + zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(ii,j) + ENDDO + zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)/float(ideltax) + ENDDO + DO i=ihalph+1,iusn-ihalph + DO ii=-ihalph,ihalph + zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)+entree(i+ii,j) + ENDDO + zusnfi(i+iext,j+1)=zusnfi(i+iext,j+1)/float(ideltax) + ENDDO + ENDIF + DO i=1,iext + zusnfi(i,j+1)=zusnfi(iusn-iext+i,j+1) + zusnfi(i+iusn+iext,j+1)=zusnfi(i,j+1) + ENDDO + ENDDO +c +c Calculer les limites des zones des nouveaux points +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 +c +c quelques initialisations: + print*,'OKM1' +c + DO i = 1, imar + DO j = 1, jmar + weight(i,j) = 0.0 + zxtzx(i,j) = 0.0 + zytzy(i,j) = 0.0 + zxtzy(i,j) = 0.0 + ztz(i,j) = 0.0 + zmea(i,j) = 0.0 + zstd(i,j)=0.0 + ENDDO + ENDDO +c +c calculs des correlations de pentes sur la grille de l'USN. +c + DO j = 2,jusn+1 + DO i = 1, iusn+2*iext + zytzyusn(i,j)=0.0 + zxtzxusn(i,j)=0.0 + zxtzyusn(i,j)=0.0 + ENDDO + ENDDO + + + DO j = 2,jusn+1 + zdeltax=zdeltay*cos(yusn(j)) + DO i = 2, iusn+2*iext-1 + zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2 + zxtzxusn(i,j)=(zusnfi(i+1,j)-zusnfi(i-1,j))**2/zdeltax**2 + zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay + * *(zusnfi(i+1,j)-zusnfi(i-1,j))/zdeltax + ENDDO + + ENDDO + + + + print*,'OK0' +c +c sommations des differentes quantites definies precedemment +c sur une grille du modele. +c + zleny=xpi/float(jusn)*rad + xincr=xpi/2./float(jusn) + DO ii = 1, imar + DO jj = 1, jmar +c PRINT *,' iteration ii jj:',ii,jj + DO j = 2,jusn+1 +c DO j = 3,jusn + zlenx=zleny*cos(yusn(j)) + zdeltax=zdeltay*cos(yusn(j)) + zbordnor=(c(jj)-yusn(j)+xincr)*rad + zbordsud=(yusn(j)-d(jj)+xincr)*rad + weighy=amax1(0., + * amin1(zbordnor,zbordsud,zleny)) + IF(weighy.ne.0)THEN + DO i = 2, iusn+2*iext-1 + zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j)) + zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j)) + weighx=amax1(0., + * amin1(zbordest,zbordoue,zlenx)) + IF(weighx.ne.0)THEN + weight(ii,jj)=weight(ii,jj)+weighx*weighy + zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy + zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy + zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy + ztz(ii,jj) =ztz(ii,jj) +zusn(i,j)*zusn(i,j)*weighx*weighy + zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c calculs des differents parametres necessaires au programme +c de parametrisation de l'orographie a l'echelle moyenne: +c + zmaxmea=0. + zmaxstd=0. + zmaxsig=0. + zmaxgam=0. + zmaxthe=0. + zminthe=0. +c print 100,' ' +c100 format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') + print*,'OK1' + DO ii = 1, imar + DO jj = 1, jmar +c print*,'ok0' + IF (weight(ii,jj) .NE. 0.0) THEN +c Orography moyenne: +c print*,'ok1' + zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj) + zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj) + zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj) + zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj) + ztz(ii,jj) =ztz(ii,jj)/weight(ii,jj) +c print*,'ok2' +c Deviation standard: + zstd(ii,jj)=sqrt(amax1(0.,ztz(ii,jj)-zmea(ii,jj)**2)) +c Coefficients K, L et M: + xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2. + xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2. + xm=zxtzy(ii,jj) + xp=xk-sqrt(xl**2+xm**2) + xq=xk+sqrt(xl**2+xm**2) + xw=1.e-8 + if(xp.le.xw) xp=0. + if(xq.le.xw) xq=xw + if(abs(xm).le.xw) xm=xw*sign(1.,xm) +c print*,'ok3' +c pente: + zsig(ii,jj)=sqrt(xq) +c zsig(ii,jj)=sqrt(2.*xk) +c isotropy: + zgam(ii,jj)=xp/xq +c angle theta: + zthe(ii,jj)=57.29577951*atan2(xm,xl)/2. + +c print 101,ii,jj, +c * zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj), +c * zthe(ii,jj) +c101 format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1) +c print*,'ok4' + ELSE +c PRINT*, 'probleme,ii,jj=', ii,jj +c print*,'ok1b' + ENDIF + zmaxmea=amax1(zmea(ii,jj),zmaxmea) +c print*,'oka' + zmaxstd=amax1(zstd(ii,jj),zmaxstd) +c print*,'okb' + zmaxsig=amax1(zsig(ii,jj),zmaxsig) +c print*,'okc' + zmaxgam=amax1(zgam(ii,jj),zmaxgam) +c print*,'okd' + zmaxthe=amax1(zthe(ii,jj),zmaxthe) +c print*,'oke' + zminthe=amin1(zthe(ii,jj),zminthe) +c print*,'ok5' + ENDDO + ENDDO + + print *,' MEAN ORO:',zmaxmea + print *,' ST. DEV.:',zmaxstd + print *,' PENTE:',zmaxsig + print *,' ANISOTROP:',zmaxgam + print *,' ANGLE:',zminthe,zmaxthe + +C +c On passe ce donnees sur la grille dite physique....(?) +c On met gamma et theta a 1. et 0. aux poles ou ces quantites +c n'ont pas vraiment de sens +c + DO jj=1,jmar + zmea(imar+1,jj)=zmea(1,jj) + zstd(imar+1,jj)=zstd(1,jj) + zsig(imar+1,jj)=zsig(1,jj) + zgam(imar+1,jj)=zgam(1,jj) + zthe(imar+1,jj)=zthe(1,jj) + ENDDO + + + zmeanor=0.0 + zmeasud=0.0 + zstdnor=0.0 + zstdsud=0.0 + zsignor=0.0 + zsigsud=0.0 + zweinor=0.0 + zweisud=0.0 + + DO ii=1,imar + zweinor=zweinor+ weight(ii, 1) + zweisud=zweisud+ weight(ii,jmar) + zmeanor=zmeanor+zmea(ii, 1)*weight(ii, 1) + zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar) + zstdnor=zstdnor+zstd(ii, 1)*weight(ii, 1) + zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar) + zsignor=zsignor+zsig(ii, 1)*weight(ii, 1) + zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar) + ENDDO + + DO ii=1,imar+1 + zmea(ii, 1)=zmeanor/zweinor + zmea(ii,jmar)=zmeasud/zweisud + zstd(ii, 1)=zstdnor/zweinor + zstd(ii,jmar)=zstdsud/zweisud + zsig(ii, 1)=zsignor/zweinor + zsig(ii,jmar)=zsigsud/zweisud + zgam(ii, 1)=1. + zgam(ii,jmar)=1. + zthe(ii, 1)=0. + zthe(ii,jmar)=0. + ENDDO + + + RETURN + END Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/ini_archive.F =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/ini_archive.F (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/ini_archive.F (revision 1540) @@ -0,0 +1,529 @@ +c======================================================================= + subroutine ini_archive(nid,idayref,phis,ith,tab_cntrl_fi, + & tab_cntrl_dyn) +c======================================================================= +c +c +c Date: 01/1997 +c ---- +c +c Objet: ecriture de l'entete du fichier "start_archive" +c ----- +c +c Proche de iniwrite.F +c +c On ajoute dans le tableau "tab_cntrl" (dynamique), a partir de 51, +c les valeurs de tab_cntrl_fi (les 38 parametres de controle physiques +c du RUN + ptotal et cotoicetotal) +c +c tab_cntrl(50+l)=tab_cntrl_fi(l) +c +c Arguments: +c --------- +c +c Inputs: +c ------ +c +c nid unite logique du fichier "start_archive" +c idayref Valeur du jour initial a mettre dans +c l'entete du fichier "start_archive" +c phis geopotentiel au sol +c ith soil thermal inertia +c tab_cntrl_fi tableau des param physiques +c + +c======================================================================= + + USE comsoil_h + USE slab_ice_h, only: noceanmx +! use control_mod + USE comvert_mod, ONLY: ap,bp,aps,bps,presnivs,pseudoalt + USE comconst_mod, ONLY: daysec,dtvr,rad,omeg,g,kappa,pi + implicit none + +#include "dimensions.h" +!#include "dimphys.h" +#include "paramet.h" +#include "comgeom.h" +!#include "control.h" + +#include "netcdf.inc" + +c----------------------------------------------------------------------- +c Declarations +c----------------------------------------------------------------------- + +c Local: +c ------ + INTEGER length,l + parameter (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER loop + INTEGER ierr, setvdim, putvdim, putdat, setname,cluvdb + INTEGER setdim + INTEGER ind1,indlast + +c Arguments: +c ---------- + INTEGER*4 idayref + REAL phis(ip1jmp1) + real ith(ip1jmp1,nsoilmx) + REAL tab_cntrl_fi(length) + REAL tab_cntrl_dyn(length) + +!Mars --------Ajouts----------- +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3) !, dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_llmp1,idim_llm + INTEGER idim_tim + INTEGER idim_nsoilmx ! "subsurface_layers" dimension ID # + INTEGER idim_noceanmx ! "ocean_layers" dimension ID # + INTEGER nid,nvarid + real sig_s(llm),s(llm) + + pi = 2. * ASIN(1.) + + +c----------------------------------------------------------------------- +c Remplissage du tableau des parametres de controle du RUN (dynamique) +c----------------------------------------------------------------------- + + DO l=1,length + tab_cntrl(l)=0. + ENDDO + + tab_cntrl(1:50)=tab_cntrl_dyn(1:50) + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! tab_cntrl(1) = FLOAT(iim) ! nombre de points en longitude +! tab_cntrl(2) = FLOAT(jjm) ! nombre de points en latitude +! tab_cntrl(3) = FLOAT(llm) ! nombre de couches +! tab_cntrl(4) = FLOAT(idayref) ! jour 0 +! tab_cntrl(5) = rad ! rayon de mars(m) ~3397200 +! tab_cntrl(6) = omeg ! vitesse de rotation (rad.s-1) +! tab_cntrl(7) = g ! gravite (m.s-2) ~3.72 +! tab_cntrl(8) = cpp +! tab_cntrl(8) = 43.49 !mars temporaire Masse molaire de l''atm (g.mol-1) ~43.49 +! tab_cntrl(9) = kappa ! = r/cp ~0.256793 (=rcp dans physique) +! tab_cntrl(10) = daysec ! duree du sol (s) ~88775 +! tab_cntrl(11) = dtvr ! pas de temps de la dynamique (s) +! tab_cntrl(12) = etot0 ! energie totale ! +! tab_cntrl(13) = ptot0 ! pression totalei ! variables +! tab_cntrl(14) = ztot0 ! enstrophie totale ! de controle +! tab_cntrl(15) = stot0 ! enthalpie totale ! globales +! tab_cntrl(16) = ang0 ! moment cinetique ! +! tab_cntrl(17) = pa +! tab_cntrl(18) = preff + +c ..... parametres pour le zoom ...... + +! tab_cntrl(19) = clon ! longitude en degres du centre du zoom +! tab_cntrl(20) = clat ! latitude en degres du centre du zoom +! tab_cntrl(21) = grossismx ! facteur de grossissement du zoom,selon longitude +! tab_cntrl(22) = grossismy ! facteur de grossissement du zoom ,selon latitude + +! IF ( fxyhypb ) THEN +! tab_cntrl(23) = 1. +! tab_cntrl(24) = dzoomx ! extension en longitude de la zone du zoom +! tab_cntrl(25) = dzoomy ! extension en latitude de la zone du zoom +! ELSE +! tab_cntrl(23) = 0. +! tab_cntrl(24) = dzoomx ! extension en longitude de la zone du zoom +! tab_cntrl(25) = dzoomy ! extension en latitude de la zone du zoom +! tab_cntrl(26) = 0. +! IF ( ysinus) tab_cntrl(26) = 1. +! ENDIF + +c----------------------------------------------------------------------- +c Copie du tableau des parametres de controle du RUN (physique) +c dans le tableau tab_cntrl +c----------------------------------------------------------------------- + + DO l=1,50 + tab_cntrl(50+l)=tab_cntrl_fi(l) + ENDDO + +c======================================================================= +c Ecriture NetCDF de l''entete du fichier "start_archive" +c======================================================================= + +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 21, + & "Fichier start_archive") +c +c Definir les dimensions du fichiers: +c +c CHAMPS AJOUTES POUR LA VISUALISATION T,ps, etc... avec Grads ou ferret: + ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm) + ierr = NF_DEF_DIM (nid,"subsurface_layers",nsoilmx,idim_nsoilmx) + ierr = NF_DEF_DIM (nid,"ocean_layers",noceanmx,idim_noceanmx) + + ierr = NF_DEF_DIM (nid,"index", length, idim_index) + ierr = NF_DEF_DIM (nid,"rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid,"rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid,"interlayer", llmp1, idim_llmp1) + ierr = NF_DEF_DIM (nid,"Time", NF_UNLIMITED, idim_tim) + +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + +c----------------------------------------------------------------------- +c Ecriture du tableau des parametres du run +c----------------------------------------------------------------------- + + call def_var(nid,"Time","Time","days since 00:00:00",1, + . idim_tim,nvarid,ierr) + + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,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----------------------------------------------------------------------- +c Ecriture des longitudes et latitudes +c----------------------------------------------------------------------- + + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif + +c----------------------------------------------------------------------- +c Ecriture des niveaux verticaux +c----------------------------------------------------------------------- + +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_llmp1,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_llmp1,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Coef A: niveaux pression hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_llmp1,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_llmp1,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 35, + . "Coefficient B niveaux sigma hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c +c ---------------------- + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aps",NF_DOUBLE,1,idim_llm,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aps",NF_FLOAT,1,idim_llm,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 36, + . "Coef AS: hybrid pressure in midlayers") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aps) +#endif +c +c ---------------------- + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bps",NF_DOUBLE,1,idim_llm,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bps",NF_FLOAT,1,idim_llm,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 30, + . "Coef BS: hybrid sigma midlayers") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bps) +#endif +c +c ---------------------- + + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_llm,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_llm,nvarid) +#endif + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c ------------------------------------------------------------------ +c Variable uniquement pour visualisation avec Grads ou Ferret +c ------------------------------------------------------------------ + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"latitude",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"latitude",NF_FLOAT,1,idim_rlatu,nvarid) +#endif + ierr =NF_PUT_ATT_TEXT(nid,nvarid,'units',13,"degrees_north") + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14, + . "North latitude") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180) +#endif +c---------------------- + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr =NF_DEF_VAR(nid,"longitude", NF_DOUBLE, 1, idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR(nid,"longitude", NF_FLOAT, 1, idim_rlonv,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 14, + . "East longitude") + ierr = NF_PUT_ATT_TEXT(nid,nvarid,'units',12,"degrees_east") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180) +#endif +c-------------------------- + ierr = NF_REDEF (nid) +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "altitude", NF_DOUBLE, 1, + . idim_llm,nvarid) +#else + ierr = NF_DEF_VAR (nid, "altitude", NF_FLOAT, 1, + . idim_llm,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",10,"pseudo-alt") + ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km") + ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up") + + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pseudoalt) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,pseudoalt) +#endif + +!------------------------------- +! (soil) depth variable mlayer() (known from comsoil.h) +!------------------------------- + ierr=NF_REDEF (nid) ! Enter NetCDF (re-)define mode + ! define variable +#ifdef NC_DOUBLE + ierr=NF_DEF_VAR(nid,"soildepth",NF_DOUBLE,1,idim_nsoilmx,nvarid) +#else + ierr=NF_DEF_VAR(nid,"soildepth",NF_FLOAT,1,idim_nsoilmx,nvarid) +#endif + ierr=NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 20, + . "Soil mid-layer depth") + ierr=NF_PUT_ATT_TEXT (nid,nvarid,"units",1,"m") + ierr=NF_PUT_ATT_TEXT (nid,nvarid,"positive",4,"down") + ierr=NF_ENDDEF(nid) ! Leave NetCDF define mode + ! write variable +#ifdef NC_DOUBLE + ierr=NF_PUT_VAR_DOUBLE (nid,nvarid,mlayer) +#else + ierr=NF_PUT_VAR_REAL (nid,nvarid,mlayer) +#endif + +!--------------------- +! soil thermal inertia +!--------------------- + ierr=NF_REDEF (nid) ! Enter NetCDF (re-)define mode + dims3(1)=idim_rlonv + dims3(2)=idim_rlatu + dims3(3)=idim_nsoilmx + ! define variable +#ifdef NC_DOUBLE + ierr=NF_DEF_VAR(nid,"inertiedat",NF_DOUBLE,3,dims3,nvarid) +#else + ierr=NF_DEF_VAR(nid,"inertiedat",NF_FLOAT,3,dims3,nvarid) +#endif + ierr=NF_PUT_ATT_TEXT (nid,nvarid,"long_name", 20, + & "Soil thermal inertia") + ierr=NF_PUT_ATT_TEXT (nid,nvarid,"units",15, + & "J.s-1/2.m-2.K-1") + ierr=NF_ENDDEF(nid) ! Leave NetCDF define mode + ! write variable +#ifdef NC_DOUBLE + ierr=NF_PUT_VAR_DOUBLE (nid,nvarid,ith) +#else + ierr=NF_PUT_VAR_REAL (nid,nvarid,ith) +#endif + +c----------------------------------------------------------------------- +c Ecriture aire et coefficients de passage cov. <-> contra. <--> naturel +c----------------------------------------------------------------------- + + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif + +c----------------------------------------------------------------------- +c Ecriture du geopentiel au sol +c----------------------------------------------------------------------- + + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif + + PRINT*,'ini_archive: iim,jjm,llm,idayref',iim,jjm,llm,idayref + PRINT*,'ini_archive: rad,omeg,g,mugaz,kappa', + s rad,omeg,g,tab_cntrl_fi(8),kappa + PRINT*,'ini_archive: daysec,dtvr',daysec,dtvr + + RETURN + END Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/iniphysiq_mod.F90 =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/iniphysiq_mod.F90 (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/iniphysiq_mod.F90 (revision 1540) @@ -0,0 +1,201 @@ +MODULE iniphysiq_mod + +CONTAINS + +subroutine iniphysiq(ii,jj,nlayer,punjours, pdayref,ptimestep, & + rlatudyn,rlatvdyn,rlonudyn,rlonvdyn,airedyn,cudyn,cvdyn, & + prad,pg,pr,pcpp,iflag_phys) + +use dimphy, only : klev ! number of atmospheric levels +use mod_grid_phy_lmdz, only : klon_glo ! number of atmospheric columns + ! (on full grid) +use mod_phys_lmdz_para, only : klon_omp, & ! number of columns (on local omp grid) + klon_omp_begin, & ! start index of local omp subgrid + klon_omp_end, & ! end index of local omp subgrid + klon_mpi_begin ! start indes of columns (on local mpi grid) +use control_mod, only: nday +use comgeomphy, only : initcomgeomphy, & + airephy, & ! physics grid area (m2) + cuphy, & ! cu coeff. (u_covariant = cu * u) + cvphy, & ! cv coeff. (v_covariant = cv * v) + rlond, & ! longitudes + rlatd ! latitudes +use surf_heat_transp_mod, only: ini_surf_heat_transp +use infotrac, only : nqtot ! number of advected tracers +use planete_mod, only: ini_planete_mod +USE comvert_mod, ONLY: ap,bp,preff +use inifis_mod, only: inifis +use regular_lonlat_mod, only: init_regular_lonlat, & + east, west, north, south, & + north_east, north_west, & + south_west, south_east +use ioipsl_getin_p_mod, only: getin_p + +implicit none +include "dimensions.h" +include "paramet.h" +include "comgeom.h" +include "iniprint.h" + +real,intent(in) :: prad ! radius of the planet (m) +real,intent(in) :: pg ! gravitational acceleration (m/s2) +real,intent(in) :: pr ! ! reduced gas constant R/mu +real,intent(in) :: pcpp ! specific heat Cp +real,intent(in) :: punjours ! length (in s) of a standard day +!integer,intent(in) :: ngrid ! number of horizontal grid points in the physics (full grid) +integer,intent(in) :: nlayer ! number of atmospheric layers +integer,intent(in) :: ii ! number of atmospheric coulumns along longitudes +integer,intent(in) :: jj ! number of atompsheric columns along latitudes +real,intent(in) :: rlatudyn(jj+1) ! latitudes of the physics grid +real,intent(in) :: rlatvdyn(jj) ! latitude boundaries of the physics grid +real,intent(in) :: rlonvdyn(ii+1) ! longitudes of the physics grid +real,intent(in) :: rlonudyn(ii+1) ! longitude boundaries of the physics grid +real,intent(in) :: airedyn(ii+1,jj+1) ! area of the dynamics grid (m2) +real,intent(in) :: cudyn((ii+1)*(jj+1)) ! cu coeff. (u_covariant = cu * u) +real,intent(in) :: cvdyn((ii+1)*jj) ! cv coeff. (v_covariant = cv * v) +integer,intent(in) :: pdayref ! reference day of for the simulation +real,intent(in) :: ptimestep !physics time step (s) +integer,intent(in) :: iflag_phys ! type of physics to be called + +integer :: ibegin,iend,offset +integer :: i,j +character(len=20) :: modname='iniphysiq' +character(len=80) :: abort_message +real :: total_area_phy, total_area_dyn +real :: pi +logical :: ok_slab_ocean + +! boundaries, on global grid +real,allocatable :: boundslon_reg(:,:) +real,allocatable :: boundslat_reg(:,:) + +! global array, on full physics grid: +real,allocatable :: latfi(:) +real,allocatable :: lonfi(:) +real,allocatable :: cufi(:) +real,allocatable :: cvfi(:) +real,allocatable :: airefi(:) + +pi=2.*asin(1.0) + +IF (nlayer.NE.klev) THEN + write(*,*) 'STOP in ',trim(modname) + write(*,*) 'Problem with dimensions :' + write(*,*) 'nlayer = ',nlayer + write(*,*) 'klev = ',klev + abort_message = '' + CALL abort_gcm (modname,abort_message,1) +ENDIF + +!IF (ngrid.NE.klon_glo) THEN +! write(*,*) 'STOP in ',trim(modname) +! write(*,*) 'Problem with dimensions :' +! write(*,*) 'ngrid = ',ngrid +! write(*,*) 'klon = ',klon_glo +! abort_message = '' +! CALL abort_gcm (modname,abort_message,1) +!ENDIF + +!call init_phys_lmdz(iim,jjm+1,llm,1,(/(jjm-1)*iim+2/)) + +! init regular global longitude-latitude grid points and boundaries +ALLOCATE(boundslon_reg(ii,2)) +ALLOCATE(boundslat_reg(jj+1,2)) + +DO i=1,ii + boundslon_reg(i,east)=rlonudyn(i) + boundslon_reg(i,west)=rlonudyn(i+1) +ENDDO + +boundslat_reg(1,north)= PI/2 +boundslat_reg(1,south)= rlatvdyn(1) +DO j=2,jj + boundslat_reg(j,north)=rlatvdyn(j-1) + boundslat_reg(j,south)=rlatvdyn(j) +ENDDO +boundslat_reg(jj+1,north)= rlatvdyn(jj) +boundslat_reg(jj+1,south)= -PI/2 + +! Write values in module regular_lonlat_mod +CALL init_regular_lonlat(ii,jj+1, rlonvdyn(1:ii), rlatudyn, & + boundslon_reg, boundslat_reg) + +! Generate global arrays on full physics grid +allocate(latfi(klon_glo),lonfi(klon_glo),cufi(klon_glo),cvfi(klon_glo)) +latfi(1)=rlatudyn(1) +lonfi(1)=0. +cufi(1) = cudyn(1) +cvfi(1) = cvdyn(1) +DO j=2,jj + DO i=1,ii + latfi((j-2)*ii+1+i)= rlatudyn(j) + lonfi((j-2)*ii+1+i)= rlonvdyn(i) + cufi((j-2)*ii+1+i) = cudyn((j-1)*(ii+1)+i) + cvfi((j-2)*ii+1+i) = cvdyn((j-1)*(ii+1)+i) + ENDDO +ENDDO +latfi(klon_glo)= rlatudyn(jj+1) +lonfi(klon_glo)= 0. +cufi(klon_glo) = cudyn((ii+1)*jj+1) +cvfi(klon_glo) = cvdyn((ii+1)*jj-ii) + +! build airefi(), mesh area on physics grid +allocate(airefi(klon_glo)) +CALL gr_dyn_fi(1,ii+1,jj+1,klon_glo,airedyn,airefi) +! Poles are single points on physics grid +airefi(1)=sum(airedyn(1:ii,1)) +airefi(klon_glo)=sum(airedyn(1:ii,jj+1)) + +! Sanity check: do total planet area match between physics and dynamics? +total_area_dyn=sum(airedyn(1:ii,1:jj+1)) +total_area_phy=sum(airefi(1:klon_glo)) +IF (total_area_dyn/=total_area_phy) THEN + WRITE (lunout, *) 'iniphysiq: planet total surface discrepancy !!!' + WRITE (lunout, *) ' in the dynamics total_area_dyn=', total_area_dyn + WRITE (lunout, *) ' but in the physics total_area_phy=', total_area_phy + IF (abs(total_area_dyn-total_area_phy)>0.00001*total_area_dyn) THEN + ! stop here if the relative difference is more than 0.001% + abort_message = 'planet total surface discrepancy' + CALL abort_gcm(modname, abort_message, 1) + ENDIF +ENDIF + + +!$OMP PARALLEL +! Now generate local lon/lat/cu/cv/area arrays +call initcomgeomphy + +!!!!$OMP PARALLEL PRIVATE(ibegin,iend) & +!!! !$OMP SHARED(airefi,cufi,cvfi,lonfi,latfi) + +offset=klon_mpi_begin-1 +airephy(1:klon_omp)=airefi(offset+klon_omp_begin:offset+klon_omp_end) +cuphy(1:klon_omp)=cufi(offset+klon_omp_begin:offset+klon_omp_end) +cvphy(1:klon_omp)=cvfi(offset+klon_omp_begin:offset+klon_omp_end) +rlond(1:klon_omp)=lonfi(offset+klon_omp_begin:offset+klon_omp_end) +rlatd(1:klon_omp)=latfi(offset+klon_omp_begin:offset+klon_omp_end) + +! copy over preff , ap() and bp() +call ini_planete_mod(nlayer,preff,ap,bp) + +! for slab ocean, copy over some arrays +ok_slab_ocean=.false. ! default value +call getin_p("ok_slab_ocean",ok_slab_ocean) +if (ok_slab_ocean) then + call ini_surf_heat_transp(ip1jm,ip1jmp1,unsairez,fext,unsaire, & + cu,cuvsurcv,cv,cvusurcu,aire,apoln,apols, & + aireu,airev) +endif + +! copy some fundamental parameters to physics +! and do some initializations +call inifis(klon_omp,nlayer,nqtot,pdayref,punjours,nday,ptimestep, & + rlatd,rlond,airephy,prad,pg,pr,pcpp) + +!$OMP END PARALLEL + + +end subroutine iniphysiq + + +END MODULE iniphysiq_mod Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/interp_vert.F =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/interp_vert.F (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/interp_vert.F (revision 1540) @@ -0,0 +1,70 @@ +c****************************************************** + SUBROUTINE interp_vert(varo,varn,lmo,lmn,apso,bpso, + & aps,bps,ps,Nhoriz) +c +c interpolation lineaire pour passer +c a une nouvelle discretisation verticale pour +c les variables de GCM +c Francois Forget (01/1995) +c Modif pour coordonnees hybrides FF (03/2003) +c********************************************************** + + IMPLICIT NONE + +c Declarations: +c ============== +c +c ARGUMENTS +c """"""""" + + integer lmo ! dimensions ancienne couches (input) + integer lmn ! dimensions nouvelle couches (input) + + real apso(lmo),bpso(lmo)! anciennes coord hybrides midlayer (input) + real aps(lmn), bps(lmn)! nouvelles coord hybrides (midlayer) (input) + + integer Nhoriz ! nombre de point horizontale (input) + real ps(nhoriz) !pression de surface (input) + + real varo(Nhoriz,lmo) ! var dans l''ancienne grille (input) + real varn(Nhoriz,lmn) ! var dans la nouvelle grille (output) + +c Autres variables +c """""""""""""""" + integer n, ln ,lo + real coef + REAL sigmo(lmo) ! niveau sigma des variables dans les anciennes coord + REAL sigmn(lmn) ! niveau sigma des variables dans les nouvelles coord + +c run +c ==== + + do n=1,Nhoriz + do ln=1,lmn + sigmn(ln)=aps(ln)/ps(n)+bps(ln) + end do + do lo=1,lmo + sigmo(lo)=apso(lo)/ps(n)+bpso(lo) + end do + + do ln=1,lmn + if (sigmn(ln).ge.sigmo(1))then + varn(n,ln) = varo(n,1) + else if (sigmn(ln).le.sigmo(lmo)) then + varn(n,ln) = varo(n,lmo) + else + do lo =1,lmo-1 + if ( (sigmn(ln).le.sigmo(lo)).and. + & (sigmn(ln).gt.sigmo(lo+1)) )then + coef = (sigmn(ln)-sigmo(lo))/(sigmo(lo+1)-sigmo(lo)) + varn(n,ln)=varo(n,lo) +coef*(varo(n,lo+1)-varo(n,lo)) + end if + end do + end if + end do + + end do + + + return + end Index: /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/lect_start_archive.F =================================================================== --- /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/lect_start_archive.F (revision 1540) +++ /trunk/LMDZ.GENERIC/libf/dynphy_lonlat/phystd/lect_start_archive.F (revision 1540) @@ -0,0 +1,1492 @@ + SUBROUTINE lect_start_archive(ngrid,nlayer, + & date,tsurf,tsoil,emis,q2, + & t,ucov,vcov,ps,h,phisold_newgrid, + & q,qsurf,surfith,nid, + & rnat,pctsrf_sic,tslab,tsea_ice,sea_ice) + +! USE surfdat_h + USE comsoil_h, ONLY: nsoilmx, layer, mlayer, volcapa, inertiedat + USE tracer_h, ONLY: igcm_co2_ice + USE infotrac, ONLY: tname, nqtot + USE slab_ice_h, ONLY: noceanmx +! USE control_mod +! to use 'getin' + USE callkeys_mod, ONLY: ok_slab_ocean + USE comvert_mod, ONLY: ap,bp,aps,bps,preff + USE comconst_mod, ONLY: kappa,g,pi + +c======================================================================= +c +c +c Auteur: 05/1997 , 12/2003 : coord hybride FF +c ------ +c +c +c Objet: Lecture des variables d'un fichier "start_archive" +c Plus besoin de régler ancienne valeurs grace +c a l'allocation dynamique de memoire (Yann Wanherdrick) +c +c +c +c======================================================================= + + implicit none + +#include "dimensions.h" +!#include "dimphys.h" +!#include "planete.h" +#include "paramet.h" +#include "comgeom2.h" +!#include "control.h" +#include "netcdf.inc" +!#include"advtrac.h" +c======================================================================= +c Declarations +c======================================================================= + + INTEGER,INTENT(IN) :: ngrid, nlayer + +c Old variables dimensions (from file) +c------------------------------------ + INTEGER imold,jmold,lmold,nsoilold,nqold + + +c Variables pour les lectures des fichiers "ini" +c-------------------------------------------------- +! INTEGER sizei, + integer timelen,dimid +! INTEGER length +! parameter (length = 100) + INTEGER tab0 + INTEGER isoil,iq,iqmax + CHARACTER*2 str2 + +! REAL dimfirst(4) ! tableau contenant les 1ers elements des dimensions + +! REAL dimlast(4) ! tableau contenant les derniers elements des dimensions + +! REAL dimcycl(4) ! tableau contenant les periodes des dimensions +! CHARACTER*120 dimsource +! CHARACTER*16 dimname +! CHARACTER*80 dimtitle +! CHARACTER*40 dimunits +! INTEGER dimtype + +! INTEGER dimord(4) ! tableau contenant l''ordre +! data dimord /1,2,3,4/ ! de sortie des dimensions + +! INTEGER vardim(4) + REAL date + INTEGER memo +! character (len=50) :: tmpname + +c Variable histoire +c------------------ + REAL vcov(iip1,jjm,llm),ucov(iip1,jjp1,llm) ! vents covariants + REAL h(iip1,jjp1,llm),ps(iip1,jjp1) + REAL q(iip1,jjp1,llm,nqtot),qtot(iip1,jjp1,llm) + +c autre variables dynamique nouvelle grille +c------------------------------------------ + +c!-*- +! integer klatdat,klongdat +! PARAMETER (klatdat=180,klongdat=360) + +c Physique sur grille scalaire +c---------------------------- + +c variable physique +c------------------ + REAL tsurf(ngrid) ! surface temperature + REAL tsoil(ngrid,nsoilmx) ! soil temperature + REAL co2ice(ngrid) ! CO2 ice layer + REAL emis(ngrid) + REAL q2(ngrid,llm+1),qsurf(ngrid,nqtot) + REAL tslab(ngrid,noceanmx) + REAL rnat(ngrid),pctsrf_sic(ngrid) + REAL tsea_ice(ngrid),sea_ice(ngrid) +c REAL phisfi(ngrid) + + INTEGER i,j,l + INTEGER nid,nvarid +c REAL year_day,periheli,aphelie,peri_day +c REAL obliquit,z0,emin_turb,lmixmin +c REAL emissiv,emisice(2),albedice(2) +c REAL iceradius(2) , dtemisice(2) + + integer ierr + integer, dimension(4) :: start,count + +c Variable nouvelle grille naturelle au point scalaire +c------------------------------------------------------ + real us(iip1,jjp1,llm),vs(iip1,jjp1,llm) + REAL phisold_newgrid(iip1,jjp1) + REAL t(iip1,jjp1,llm) + real tsurfS(iip1,jjp1),tsoilS(iip1,jjp1,nsoilmx) + real inertiedatS(iip1,jjp1,nsoilmx) + real co2iceS(iip1,jjp1) + real emisS(iip1,jjp1) + REAL q2S(iip1,jjp1,llm+1),qsurfS(iip1,jjp1,nqtot) + real tslabS(iip1,jjp1,noceanmx) + real pctsrf_sicS(iip1,jjp1),tsea_iceS(iip1,jjp1) + real rnatS(iip1,jjp1), sea_iceS(iip1,jjp1) + + real ptotal, co2icetotal + +c Var intermediaires : vent naturel, mais pas coord scalaire +c----------------------------------------------------------- + real vnat(iip1,jjm,llm),unat(iip1,jjp1,llm) + + +c Variable de l'ancienne grille +c--------------------------------------------------------- + + real, dimension(:), allocatable :: timelist + real, dimension(:), allocatable :: rlonuold, rlatvold + real, dimension(:), allocatable :: rlonvold, rlatuold + real, dimension(:), allocatable :: apsold,bpsold + real, dimension(:), allocatable :: mlayerold + real, dimension(:,:,:), allocatable :: uold,vold,told,q2old + real, dimension(:,:,:), allocatable :: tsoilold,qsurfold + real, dimension(:,:,:),allocatable :: tsoiloldnew +! tsoiloldnew: old soil values, but along new subterranean grid + real, dimension(:,:,:), allocatable :: inertiedatold +! inertiedatoldnew: old inertia values, but along new subterranean grid + real, dimension(:,:,:), allocatable :: inertiedatoldnew + real, dimension(:,:), allocatable :: psold,phisold + real, dimension(:,:), allocatable :: co2iceold + real, dimension(:,:), allocatable :: tsurfold + real, dimension(:,:), allocatable :: emisold + real, dimension(:,:,:,:), allocatable :: qold + real, dimension(:,:,:), allocatable :: tslabold + real, dimension(:,:), allocatable :: rnatold,pctsrf_sicold + real, dimension(:,:), allocatable :: tsea_iceold,sea_iceold + + + real tab_cntrl(100) + + real ptotalold, co2icetotalold + + logical :: olddepthdef=.false. ! flag +! olddepthdef=.true. if soil depths are in 'old' (unspecified) format + logical :: depthinterpol=.false. ! flag +! depthinterpol=.true. if interpolation will be requiered + logical :: therminertia_3D=.true. ! flag +! therminertia_3D=.true. if thermal inertia is 3D and read from datafile +c Variable intermediaires iutilise pour l'extrapolation verticale +c---------------------------------------------------------------- + real, dimension(:,:,:), allocatable :: var,varp1 + real, dimension(:), allocatable :: oldgrid, oldval + real, dimension(:), allocatable :: newval + + real surfith(iip1,jjp1) ! surface thermal inertia + ! surface thermal inertia at old horizontal grid resolution + real, dimension(:,:), allocatable :: surfithold + + character(len=30) :: txt ! to store some text + +c======================================================================= + +! 0. Preliminary stuff + + + +!----------------------------------------------------------------------- +! 1. Read data dimensions (i.e. size and length) +!----------------------------------------------------------------------- + +! 1.2 Read the various dimension lengths of data in file + + ierr= NF_INQ_DIMID(nid,"Time",dimid) + if (ierr.ne.NF_NOERR) then + ierr= NF_INQ_DIMID(nid,"temps",dimid) + endif + ierr= NF_INQ_DIMLEN(nid,dimid,timelen) + + ierr= NF_INQ_DIMID(nid,"latitude",dimid) + if (ierr.ne.NF_NOERR) then + ierr= NF_INQ_DIMID(nid,"rlatu",dimid) + endif + ierr= NF_INQ_DIMLEN(nid,dimid,jmold) + jmold=jmold-1 + + ierr= NF_INQ_DIMID(nid,"longitude",dimid) + if (ierr.ne.NF_NOERR) then + ierr= NF_INQ_DIMID(nid,"rlonv",dimid) + endif + ierr= NF_INQ_DIMLEN(nid,dimid,imold) + imold=imold-1 + + ierr= NF_INQ_DIMID(nid,"altitude",dimid) + if (ierr.ne.NF_NOERR) then + ierr= NF_INQ_DIMID(nid,"sig_s",dimid) + endif + ierr= NF_INQ_DIMLEN(nid,dimid,lmold) + + nqold=0 + do + write(str2,'(i2.2)') nqold+1 + ierr= NF_INQ_VARID(nid,'q'//str2,dimid) +! write(*,*) 'q'//str2 + if (ierr.eq.NF_NOERR) then + nqold=nqold+1 + else + exit + endif + enddo + +! 1.2.1 find out the # of subsurface_layers + nsoilold=0 !dummy initialisation + ierr=NF_INQ_DIMID(nid,"subsurface_layers",dimid) + if (ierr.eq.NF_NOERR) then + ierr=NF_INQ_DIMLEN(nid,dimid,nsoilold) + if (ierr.ne.NF_NOERR) then + write(*,*)'lec_start_archive: ', + & 'Failed reading subsurface_layers length' + endif + else + write(*,*)"lec_start_archive: did not find subsurface_layers" + endif + + if (nsoilold.eq.0) then ! 'old' archive format; + ! must use Tg//str2 fields to compute nsoilold + write(*,*)"lec_start_archive: building nsoilold from Tg fields" + do + write(str2,'(i2.2)') nsoilold+1 + ierr=NF_INQ_VARID(nid,'Tg'//str2,dimid) + if (ierr.eq.NF_NOERR) then + nsoilold=nsoilold+1 + else + exit + endif + enddo + endif + + + if (nsoilold.ne.nsoilmx) then ! interpolation will be required + depthinterpol=.true. + endif + +! 1.3 Report dimensions + + write(*,*) "Start_archive dimensions:" + write(*,*) "longitude: ",imold + write(*,*) "latitude: ",jmold + write(*,*) "altitude: ",lmold + write(*,*) "tracers: ",nqold + write(*,*) "subsurface_layers: ",nsoilold + if (depthinterpol) then + write(*,*) " => Warning, nsoilmx= ",nsoilmx + write(*,*) ' which implies that you want subterranean interpola + &tion.' + write(*,*) ' Otherwise, set nsoilmx -in dimphys.h- to: ',nsoilold + endif + write(*,*) "time lenght: ",timelen + write(*,*) + +!----------------------------------------------------------------------- +! 2. Allocate arrays to store datasets +!----------------------------------------------------------------------- + + allocate(timelist(timelen)) + allocate(rlonuold(imold+1), rlatvold(jmold)) + allocate(rlonvold(imold+1), rlatuold(jmold+1)) + allocate (apsold(lmold),bpsold(lmold)) + allocate(uold(imold+1,jmold+1,lmold)) + allocate(vold(imold+1,jmold+1,lmold)) + allocate(told(imold+1,jmold+1,lmold)) + allocate(psold(imold+1,jmold+1)) + allocate(phisold(imold+1,jmold+1)) + allocate(qold(imold+1,jmold+1,lmold,nqtot)) + allocate(co2iceold(imold+1,jmold+1)) + allocate(tsurfold(imold+1,jmold+1)) + allocate(emisold(imold+1,jmold+1)) + allocate(q2old(imold+1,jmold+1,lmold+1)) +! allocate(tsoilold(imold+1,jmold+1,nsoilmx)) + allocate(tsoilold(imold+1,jmold+1,nsoilold)) + allocate(tsoiloldnew(imold+1,jmold+1,nsoilmx)) + allocate(inertiedatold(imold+1,jmold+1,nsoilold)) ! soil thermal inertia + allocate(inertiedatoldnew(imold+1,jmold+1,nsoilmx)) + ! surface thermal inertia at old horizontal grid resolution + allocate(surfithold(imold+1,jmold+1)) + allocate(mlayerold(nsoilold)) + allocate(qsurfold(imold+1,jmold+1,nqtot)) + allocate(tslabold(imold+1,jmold+1,noceanmx)) + allocate(rnatold(imold+1,jmold+1)) + allocate(pctsrf_sicold(imold+1,jmold+1)) + allocate(tsea_iceold(imold+1,jmold+1)) + allocate(sea_iceold(imold+1,jmold+1)) + + allocate(var (imold+1,jmold+1,llm)) + allocate(varp1 (imold+1,jmold+1,llm+1)) + + write(*,*) 'q2',ngrid,llm+1 + write(*,*) 'q2S',iip1,jjp1,llm+1 + write(*,*) 'q2old',imold+1,jmold+1,lmold+1 + +!----------------------------------------------------------------------- +! 3. Read time-independent data +!----------------------------------------------------------------------- + +C----------------------------------------------------------------------- +c 3.1. Lecture du tableau des parametres du run +c (pour la lecture ulterieure de "ptotalold" et "co2icetotalold") +c----------------------------------------------------------------------- +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Lect_start_archive: champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echoue pour " + CALL abort + ENDIF +c + tab0 = 50 + +c----------------------------------------------------------------------- +c 3.2 Lecture des longitudes et latitudes +c----------------------------------------------------------------------- +c + ierr = NF_INQ_VARID (nid, "rlonv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonvold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonvold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "rlatu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatuold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatuold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "rlonu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonuold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonuold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + ierr = NF_INQ_VARID (nid, "rlatv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatvold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatvold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF +c + +c----------------------------------------------------------------------- +c 3.3. Lecture des niveaux verticaux +c----------------------------------------------------------------------- +c + ierr = NF_INQ_VARID (nid, "aps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + apsold=0 + PRINT*, " set to 0" + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, apsold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, apsold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + ENDIF + ENDIF +c + ierr = NF_INQ_VARID (nid, "bps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + PRINT*, "It must be an old start_archive, lets look for sig_s" + ierr = NF_INQ_VARID (nid, "sig_s", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Nothing to do..." + CALL abort + ENDIF + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, bpsold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, bpsold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + END IF + +c----------------------------------------------------------------------- +c 3.4 Read Soil layers depths +c----------------------------------------------------------------------- + + ierr=NF_INQ_VARID(nid,"soildepth",nvarid) + if (ierr.ne.NF_NOERR) then + write(*,*)'lect_start_archive: Could not find ' + write(*,*)' => Assuming this is an archive in old format' + olddepthdef=.true. + depthinterpol=.true. + ! this is how soil depth was defined in ye old days + do isoil=1,nsoilold + mlayerold(isoil)=sqrt(887.75/3.14)*((2.**(isoil-0.5))-1.) + enddo + else +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid,nvarid,mlayerold) +#else + ierr = NF_GET_VAR_REAL(nid,nvarid,mlayerold) +#endif + if (ierr .NE. NF_NOERR) then + PRINT*, "lect_start_archive: Failed reading " + CALL abort + endif + + endif !of if(ierr.ne.NF_NOERR) + + ! Read (or build) mlayer() + if (depthinterpol) then + ! Build (default) new soil depths (mlayer(:) is in comsoil.h), + ! as in soil_settings.F + write(*,*)' => Building default soil depths' + do isoil=0,nsoilmx-1 + mlayer(isoil)=2.e-4*(2.**(isoil-0.5)) + enddo + write(*,*)' => mlayer: ',mlayer + ! Also build (default) new soil interlayer depth layer(:) + do isoil=1,nsoilmx + layer(isoil)=sqrt(mlayer(0)*mlayer(1))* + & ((mlayer(1)/mlayer(0))**(isoil-1)) + enddo + write(*,*)' => layer: ',layer + else ! read mlayer() from file +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid,nvarid,mlayer) +#else + ierr = NF_GET_VAR_REAL(nid,nvarid,mlayer) +#endif + if (ierr .NE. NF_NOERR) then + PRINT*, "lect_start_archive: Failed reading " + CALL abort + endif + endif ! of if (depthinterpol) + +c----------------------------------------------------------------------- +c 3.5 Read Soil thermal inertia +c----------------------------------------------------------------------- + + ierr=NF_INQ_VARID(nid,"inertiedat",nvarid) + if (ierr.ne.NF_NOERR) then + write(*,*)'lect_start_archive: Could not find ' + write(*,*)' => Assuming this is an archive in old format' + therminertia_3D=.false. + write(*,*)' => Thermal inertia will be read from reference file' + volcapa=1.e6 + write(*,*)' and soil volumetric heat capacity is set to ', + & volcapa + else +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid,nvarid,inertiedatold) +#else + ierr = NF_GET_VAR_REAL(nid,nvarid,inertiedatold) +#endif + if (ierr .NE. NF_NOERR) then + PRINT*, "lect_start_archive: Failed reading " + CALL abort + endif + endif + +c----------------------------------------------------------------------- +c 3.6 Lecture geopotentiel au sol +c----------------------------------------------------------------------- +c + ierr = NF_INQ_VARID (nid, "phisinit", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phisold) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, phisold) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Lecture echouee pour " + CALL abort + ENDIF + +C----------------------------------------------------------------------- +c lecture de "ptotalold" et "co2icetotalold" +c----------------------------------------------------------------------- + ptotalold = tab_cntrl(tab0+49) + co2icetotalold = tab_cntrl(tab0+50) + +c----------------------------------------------------------------------- +c 4. Lecture du temps et choix +c----------------------------------------------------------------------- + +c lecture du temps +c + ierr = NF_INQ_DIMID (nid, "Time", nvarid) + IF (ierr .NE. NF_NOERR) THEN + ierr = NF_INQ_DIMID (nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "lect_start_archive: Le champ