Index: LMDZ4/branches/V3_test/libf/dyn3dpar/advect.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/advect.F (revision 706) +++ (revision ) @@ -1,166 +1,0 @@ -! -! $Header$ -! - SUBROUTINE advect(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta) - - IMPLICIT NONE -c======================================================================= -c -c Auteurs: P. Le Van , Fr. Hourdin . -c ------- -c -c Objet: -c ------ -c -c ************************************************************* -c .... calcul des termes d'advection vertic.pour u,v,teta,q ... -c ************************************************************* -c ces termes sont ajoutes a du,dv,dteta et dq . -c Modif F.Forget 03/94 : on retire q de advect -c -c======================================================================= -c----------------------------------------------------------------------- -c Declarations: -c ------------- - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" -#include "comgeom.h" -#include "logic.h" -#include "ener.h" - -c Arguments: -c ---------- - - REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) - REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm) - REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm) - -c Local: -c ------ - - REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1) - REAL unsaire2(ip1jmp1), ge(ip1jmp1) - REAL deuxjour, ww, gt, uu, vv - - INTEGER ij,l - - REAL SSUM - -c----------------------------------------------------------------------- -c 2. Calculs preliminaires: -c ------------------------- - - IF (conser) THEN - deuxjour = 2. * daysec - - DO 1 ij = 1, ip1jmp1 - unsaire2(ij) = unsaire(ij) * unsaire(ij) - 1 CONTINUE - END IF - - -c------------------ -yy ---------------------------------------------- -c . Calcul de u - - DO l=1,llm - DO ij = iip2, ip1jmp1 - uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) ) - ENDDO - DO ij = iip2, ip1jm - uav(ij,l) = uav(ij,l) + uav(ij+iip1,l) - ENDDO - DO ij = 1, iip1 - uav(ij ,l) = 0. - uav(ip1jm+ij,l) = 0. - ENDDO - ENDDO - -c------------------ -xx ---------------------------------------------- -c . Calcul de v - - DO l=1,llm - DO ij = 2, ip1jm - vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) ) - ENDDO - DO ij = 1,ip1jm,iip1 - vav(ij,l) = vav(ij+iim,l) - ENDDO - DO ij = 1, ip1jm-1 - vav(ij,l) = vav(ij,l) + vav(ij+1,l) - ENDDO - DO ij = 1, ip1jm, iip1 - vav(ij+iim,l) = vav(ij,l) - ENDDO - ENDDO - -c----------------------------------------------------------------------- - -c - DO 20 l = 1, llmm1 - - -c ...... calcul de - w/2. au niveau l+1 ....... - - DO 5 ij = 1, ip1jmp1 - wsur2( ij ) = - 0.5 * w( ij,l+1 ) - 5 CONTINUE - - -c ..................... calcul pour du .................. - - DO 6 ij = iip2 ,ip1jm-1 - ww = wsur2 ( ij ) + wsur2( ij+1 ) - uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) - du(ij,l) = du(ij,l) - ww * ( uu - uav(ij, l ) )/massebx(ij, l ) - du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) - 6 CONTINUE - -c ..... correction pour du(iip1,j,l) ........ -c ..... du(iip1,j,l)= du(1,j,l) ..... - -CDIR$ IVDEP - DO 7 ij = iip1 +iip1, ip1jm, iip1 - du( ij, l ) = du( ij -iim, l ) - du( ij,l+1 ) = du( ij -iim,l+1 ) - 7 CONTINUE - -c ................. calcul pour dv ..................... - - DO 8 ij = 1, ip1jm - ww = wsur2( ij+iip1 ) + wsur2( ij ) - vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) - dv(ij,l) = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l ) - dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) - 8 CONTINUE - -c - -c ............................................................ -c ............... calcul pour dh ................... -c ............................................................ - -c ---z -c calcul de - d( teta * w ) qu'on ajoute a dh -c ............... - - DO 15 ij = 1, ip1jmp1 - ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) - dteta(ij, l ) = dteta(ij, l ) - ww - dteta(ij,l+1) = dteta(ij,l+1) + ww - 15 CONTINUE - - IF( conser) THEN - DO 17 ij = 1,ip1jmp1 - ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) - 17 CONTINUE - gt = SSUM( ip1jmp1,ge,1 ) - gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) - END IF - - 20 CONTINUE - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/advtrac.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/advtrac.F (revision 706) +++ (revision ) @@ -1,357 +1,0 @@ -! -! $Header$ -! -c -c -#ifdef INCA_CH4 - SUBROUTINE advtrac(pbaru,pbarv , - * p, masse,q,iapptrac,teta, - * flxw, - * pk, - * mmt_adj, - * hadv_flg) -#else - SUBROUTINE advtrac(pbaru,pbarv , - * p, masse,q,iapptrac,teta, - * pk) -#endif - -c Auteur : F. Hourdin -c -c Modif. P. Le Van (20/12/97) -c F. Codron (10/99) -c D. Le Croller (07/2001) -c M.A Filiberti (04/2002) -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" -#include "comdissip.h" -#include "comgeom2.h" -#include "logic.h" -#include "temps.h" -#include "control.h" -#include "ener.h" -#include "description.h" -#include "advtrac.h" - -c------------------------------------------------------------------- -c Arguments -c------------------------------------------------------------------- -c Ajout PPM -c-------------------------------------------------------- - REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm) -c-------------------------------------------------------- - INTEGER iapptrac - REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) - REAL q(ip1jmp1,llm,nqmx),masse(ip1jmp1,llm) - REAL p( ip1jmp1,llmp1 ),teta(ip1jmp1,llm) - REAL pk(ip1jmp1,llm) -#ifdef INCA_CH4 -cym INTEGER :: hadv_flg(nq) - INTEGER :: hadv_flg(nqmx) -cym REAL :: mmt_adj(ip1jmp1,llm) - REAL :: mmt_adj(ip1jmp1,llm,1) - REAL :: flxw(ip1jmp1,llm) -#endif - -c------------------------------------------------------------- -c Variables locales -c------------------------------------------------------------- - - REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) - REAL massem(ip1jmp1,llm),zdp(ip1jmp1) - REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm) - REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu - real cpuadv(nqmx) - common/cpuadv/cpuadv - - INTEGER iadvtr - INTEGER ij,l,iq,iiq - REAL zdpmin, zdpmax - EXTERNAL minmax - SAVE iadvtr, massem, pbaruc, pbarvc - DATA iadvtr/0/ -c---------------------------------------------------------- -c Rajouts pour PPM -c---------------------------------------------------------- - INTEGER indice,n - REAL dtbon ! Pas de temps adaptatif pour que CFL<1 - REAL CFLmaxz,aaa,bbb ! CFL maximum - REAL psppm(iim,jjp1) ! pression au sol - REAL unatppm(iim,jjp1,llm),vnatppm(iim,jjp1,llm) - REAL qppm(iim*jjp1,llm,nqmx) - REAL fluxwppm(iim,jjp1,llm) - REAL apppm(llmp1), bpppm(llmp1) - LOGICAL dum,fill - DATA fill/.true./ - DATA dum/.true./ - - - IF(iadvtr.EQ.0) THEN - CALL initial0(ijp1llm,pbaruc) - CALL initial0(ijmllm,pbarvc) - ENDIF - -c accumulation des flux de masse horizontaux - DO l=1,llm - DO ij = 1,ip1jmp1 - pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) - ENDDO - DO ij = 1,ip1jm - pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) - ENDDO - ENDDO - -c selection de la masse instantannee des mailles avant le transport. - IF(iadvtr.EQ.0) THEN - - CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) -ccc CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 ) -c - ENDIF - - iadvtr = iadvtr+1 - iapptrac = iadvtr - - -c Test pour savoir si on advecte a ce pas de temps - IF ( iadvtr.EQ.iapp_tracvl ) THEN - -cc .. Modif P.Le Van ( 20/12/97 ) .... -cc - -c traitement des flux de masse avant advection. -c 1. calcul de w -c 2. groupement des mailles pres du pole. - - CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) - -#ifdef INCA_CH4 - ! ... Flux de masse diaganostiques traceurs - flxw = wg / FLOAT(iapp_tracvl) -#endif - -c test sur l'eventuelle creation de valeurs negatives de la masse - DO l=1,llm-1 - DO ij = iip2+1,ip1jm - zdp(ij) = pbarug(ij-1,l) - pbarug(ij,l) - s - pbarvg(ij-iip1,l) + pbarvg(ij,l) - s + wg(ij,l+1) - wg(ij,l) - ENDDO - CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 ) - DO ij = iip2,ip1jm - zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) - ENDDO - - - CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax ) - - IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN - PRINT*,'WARNING DP/P l=',l,' MIN:',zdpmin, - s ' MAX:', zdpmax - ENDIF - - ENDDO - -c------------------------------------------------------------------- -c Advection proprement dite (Modification Le Croller (07/2001) -c------------------------------------------------------------------- - -c---------------------------------------------------- -c Calcul des moyennes basées sur la masse -c---------------------------------------------------- - call massbar(massem,massebx,masseby) - -c----------------------------------------------------------- -c Appel des sous programmes d'advection -c----------------------------------------------------------- - do iq=1,nqmx -c call clock(t_initial) - if(iadv(iq) == 0) cycle -c ---------------------------------------------------------------- -c Schema de Van Leer I MUSCL -c ---------------------------------------------------------------- - if(iadv(iq).eq.10) THEN - call vlsplt(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr) - - -c ---------------------------------------------------------------- -c Schema "pseudo amont" + test sur humidite specifique -C pour la vapeur d'eau. F. Codron -c ---------------------------------------------------------------- - else if(iadv(iq).eq.14) then -c - CALL vlspltqs( q(1,1,1), 2., massem, wg , - * pbarug,pbarvg,dtvr,p,pk,teta ) -c ---------------------------------------------------------------- -c Schema de Frederic Hourdin -c ---------------------------------------------------------------- - else if(iadv(iq).eq.12) then -c Pas de temps adaptatif - call adaptdt(iadv(iq),dtbon,n,pbarug,massem) - if (n.GT.1) then - write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', - s dtvr,'n=',n - endif - do indice=1,n - call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1) - end do - else if(iadv(iq).eq.13) then -c Pas de temps adaptatif - call adaptdt(iadv(iq),dtbon,n,pbarug,massem) - if (n.GT.1) then - write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', - s dtvr,'n=',n - endif - do indice=1,n - call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2) - end do -c ---------------------------------------------------------------- -c Schema de pente SLOPES -c ---------------------------------------------------------------- - else if (iadv(iq).eq.20) then - call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0) -#ifdef INCA_CH4 - do iiq = iq+1, iq+3 - q(:,:,iiq)=q(:,:,iiq)*mmt_adj(:,:,1) - enddo -#endif - -c ---------------------------------------------------------------- -c Schema de Prather -c ---------------------------------------------------------------- - else if (iadv(iq).eq.30) then -c Pas de temps adaptatif - call adaptdt(iadv(iq),dtbon,n,pbarug,massem) - if (n.GT.1) then - write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', - s dtvr,'n=',n - endif - call prather(q(1,1,iq),wg,massem,pbarug,pbarvg, - s n,dtbon) -#ifdef INCA_CH4 - do iiq = iq+1, iq+9 - q(:,:,iiq)=q(:,:,iiq)*mmt_adj(:,:,1) - enddo -#endif -c ---------------------------------------------------------------- -c Schemas PPM Lin et Rood -c ---------------------------------------------------------------- - else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND. - s iadv(iq).LE.18)) then - -c Test sur le flux horizontal -c Pas de temps adaptatif - call adaptdt(iadv(iq),dtbon,n,pbarug,massem) - if (n.GT.1) then - write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', - s dtvr,'n=',n - endif -c Test sur le flux vertical - CFLmaxz=0. - do l=2,llm - do ij=iip2,ip1jm - aaa=wg(ij,l)*dtvr/massem(ij,l) - CFLmaxz=max(CFLmaxz,aaa) - bbb=-wg(ij,l)*dtvr/massem(ij,l-1) - CFLmaxz=max(CFLmaxz,bbb) - enddo - enddo - if (CFLmaxz.GE.1) then - write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz - endif - -c----------------------------------------------------------- -c Ss-prg interface LMDZ.4->PPM3d -c----------------------------------------------------------- - - call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, - s apppm,bpppm,massebx,masseby,pbarug,pbarvg, - s unatppm,vnatppm,psppm) - - do indice=1,n -c--------------------------------------------------------------------- -c VL (version PPM) horiz. et PPM vert. -c--------------------------------------------------------------------- - if (iadv(iq).eq.11) then -c Ss-prg PPM3d de Lin - call ppm3d(1,qppm(1,1,iq), - s psppm,psppm, - s unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1, - s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, - s fill,dum,220.) - -c---------------------------------------------------------------------- -c Monotonic PPM -c---------------------------------------------------------------------- - else if (iadv(iq).eq.16) then -c Ss-prg PPM3d de Lin - call ppm3d(1,qppm(1,1,iq), - s psppm,psppm, - s unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1, - s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, - s fill,dum,220.) -c--------------------------------------------------------------------- - -c--------------------------------------------------------------------- -c Semi Monotonic PPM -c--------------------------------------------------------------------- - else if (iadv(iq).eq.17) then -c Ss-prg PPM3d de Lin - call ppm3d(1,qppm(1,1,iq), - s psppm,psppm, - s unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1, - s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, - s fill,dum,220.) -c--------------------------------------------------------------------- - -c--------------------------------------------------------------------- -c Positive Definite PPM -c--------------------------------------------------------------------- - else if (iadv(iq).eq.18) then -c Ss-prg PPM3d de Lin - call ppm3d(1,qppm(1,1,iq), - s psppm,psppm, - s unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1, - s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, - s fill,dum,220.) -c--------------------------------------------------------------------- - endif - enddo -c----------------------------------------------------------------- -c Ss-prg interface PPM3d-LMDZ.4 -c----------------------------------------------------------------- - call interpost(q(1,1,iq),qppm(1,1,iq)) - endif -c---------------------------------------------------------------------- - -c----------------------------------------------------------------- -c On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1 -c et Nord j=1 -c----------------------------------------------------------------- - -c call traceurpole(q(1,1,iq),massem) - -c calcul du temps cpu pour un schema donne - -c call clock(t_final) -cym tps_cpu=t_final-t_initial -cym cpuadv(iq)=cpuadv(iq)+tps_cpu - - end DO - - -c------------------------------------------------------------------ -c on reinitialise a zero les flux de masse cumules -c--------------------------------------------------- - iadvtr=0 - - ENDIF ! if iadvtr.EQ.iapp_tracvl - - RETURN - END - Index: LMDZ4/branches/V3_test/libf/dyn3dpar/bernoui.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/bernoui.F (revision 706) +++ (revision ) @@ -1,58 +1,0 @@ -! -! $Header$ -! - SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern) - IMPLICIT NONE - -c======================================================================= -c -c Auteur: P. Le Van -c ------- -c -c Objet: -c ------ -c calcul de la fonction de Bernouilli aux niveaux s ..... -c phi et ecin sont des arguments d'entree pour le s-pg ....... -c bern est un argument de sortie pour le s-pg ...... -c -c fonction de Bernouilli = bern = filtre de( geopotentiel + -c energ.cinet.) -c -c======================================================================= -c -c----------------------------------------------------------------------- -c Decalrations: -c ------------- -c -#include "dimensions.h" -#include "paramet.h" -#include "logic.h" -c -c Arguments: -c ---------- -c - INTEGER nlay,ngrid - REAL pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay) -c -c Local: -c ------ -c - INTEGER ijl -c -c----------------------------------------------------------------------- -c calcul de Bernouilli: -c --------------------- -c - DO 4 ijl = 1,ngrid*nlay - pbern( ijl ) = pphi( ijl ) + pecin( ijl ) - 4 CONTINUE -c -c----------------------------------------------------------------------- -c filtre: -c ------- -c - CALL filtreg( pbern, jjp1, llm, 2,1, .true., 1 ) -c -c----------------------------------------------------------------------- - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/bilan_dyn.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/bilan_dyn.F (revision 706) +++ (revision ) @@ -1,582 +1,0 @@ -! -! $Header$ -! - SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum, - s ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac) - -c AFAIRE -c Prevoir en champ nq+1 le diagnostique de l'energie -c en faisant Qzon=Cv T + L * ... -c vQ..A=Cp T + L * ... - - USE IOIPSL - - IMPLICIT NONE - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" -#include "comgeom2.h" -#include "temps.h" -#include "iniprint.h" - -c==================================================================== -c -c Sous-programme consacre à des diagnostics dynamiques de base -c -c -c De facon generale, les moyennes des scalaires Q sont ponderees par -c la masse. -c -c Les flux de masse sont eux simplement moyennes. -c -c==================================================================== - -c Arguments : -c =========== - - integer ntrac - real dt_app,dt_cum - real ps(iip1,jjp1) - real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm) - real flux_u(iip1,jjp1,llm) - real flux_v(iip1,jjm,llm) - real teta(iip1,jjp1,llm) - real phi(iip1,jjp1,llm) - real ucov(iip1,jjp1,llm) - real vcov(iip1,jjm,llm) - real trac(iip1,jjp1,llm,ntrac) - -c Local : -c ======= - - integer icum,ncum - logical first - real zz,zqy,zfactv(jjm,llm) - - integer nQ - parameter (nQ=7) - - -cym character*6 nom(nQ) -cym character*6 unites(nQ) - character*6,save :: nom(nQ) - character*6,save :: unites(nQ) - - character*10 file - integer ifile - parameter (ifile=4) - - integer itemp,igeop,iecin,iang,iu,iovap,iun - integer i_sortie - - save first,icum,ncum - save itemp,igeop,iecin,iang,iu,iovap,iun - save i_sortie - - real time - integer itau - save time,itau - data time,itau/0.,0/ - - data first/.true./ - data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/ - data i_sortie/1/ - - real ww - -c variables dynamiques intermédiaires - REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm) - REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm) - REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) - REAL vorpot(iip1,jjm,llm) - REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm) - REAL bern(iip1,jjp1,llm) - -c champ contenant les scalaires advectés. - real Q(iip1,jjp1,llm,nQ) - -c champs cumulés - real ps_cum(iip1,jjp1) - real masse_cum(iip1,jjp1,llm) - real flux_u_cum(iip1,jjp1,llm) - real flux_v_cum(iip1,jjm,llm) - real Q_cum(iip1,jjp1,llm,nQ) - real flux_uQ_cum(iip1,jjp1,llm,nQ) - real flux_vQ_cum(iip1,jjm,llm,nQ) - real flux_wQ_cum(iip1,jjp1,llm,nQ) - real dQ(iip1,jjp1,llm,nQ) - - save ps_cum,masse_cum,flux_u_cum,flux_v_cum - save Q_cum,flux_uQ_cum,flux_vQ_cum - -c champs de tansport en moyenne zonale - integer ntr,itr - parameter (ntr=5) - -cym character*10 znom(ntr,nQ) -cym character*20 znoml(ntr,nQ) -cym character*10 zunites(ntr,nQ) - character*10,save :: znom(ntr,nQ) - character*20,save :: znoml(ntr,nQ) - character*10,save :: zunites(ntr,nQ) - - integer iave,itot,immc,itrs,istn - data iave,itot,immc,itrs,istn/1,2,3,4,5/ - character*3 ctrs(ntr) - data ctrs/' ','TOT','MMC','TRS','STN'/ - - real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm) - real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ) - real zmasse(jjm,llm),zamasse(jjm) - - real zv(jjm,llm),psi(jjm,llm+1) - - integer i,j,l,iQ - - -c Initialisation du fichier contenant les moyennes zonales. -c --------------------------------------------------------- - - character*10 infile - - integer fileid - integer thoriid, zvertiid - save fileid - - integer ndex3d(jjm*llm) - -C Variables locales -C - integer tau0 - real zjulian - character*3 str - character*10 ctrac - integer ii,jj - integer zan, dayref -C - real rlong(jjm),rlatg(jjm) - - - -c===================================================================== -c Initialisation -c===================================================================== - - time=time+dt_app - itau=itau+1 - - if (first) then - - - icum=0 -c initialisation des fichiers - first=.false. -c ncum est la frequence de stokage en pas de temps - ncum=dt_cum/dt_app - if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then - WRITE(lunout,*) - . 'Pb : le pas de cumule doit etre multiple du pas' - WRITE(lunout,*)'dt_app=',dt_app - WRITE(lunout,*)'dt_cum=',dt_cum - stop - endif - - if (i_sortie.eq.1) then - file='dynzon' - call inigrads(ifile,1 - s ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi - s ,llm,presnivs,1. - s ,dt_cum,file,'dyn_zon ') - endif - - nom(itemp)='T' - nom(igeop)='gz' - nom(iecin)='K' - nom(iang)='ang' - nom(iu)='u' - nom(iovap)='ovap' - nom(iun)='un' - - unites(itemp)='K' - unites(igeop)='m2/s2' - unites(iecin)='m2/s2' - unites(iang)='ang' - unites(iu)='m/s' - unites(iovap)='kg/kg' - unites(iun)='un' - - -c Initialisation du fichier contenant les moyennes zonales. -c --------------------------------------------------------- - - infile='dynzon' - - zan = annee_ref - dayref = day_ref - CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) - tau0 = itau_dyn - - rlong=0. - rlatg=rlatv*180./pi - - call histbeg(infile, 1, rlong, jjm, rlatg, - . 1, 1, 1, jjm, - . tau0, zjulian, dt_cum, thoriid, fileid) - -C -C Appel a histvert pour la grille verticale -C - call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', - . llm, presnivs, zvertiid) -C -C Appels a histdef pour la definition des variables a sauvegarder - do iQ=1,nQ - do itr=1,ntr - if(itr.eq.1) then - znom(itr,iQ)=nom(iQ) - znoml(itr,iQ)=nom(iQ) - zunites(itr,iQ)=unites(iQ) - else - znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ) - znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr) - zunites(itr,iQ)='m/s * '//unites(iQ) - endif - enddo - enddo - -c Declarations des champs avec dimension verticale -c print*,'1HISTDEF' - do iQ=1,nQ - do itr=1,ntr - IF (prt_level > 5) - . WRITE(lunout,*)'var ',itr,iQ - . ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ) - call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), - . zunites(itr,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, - . 32,'ave(X)',dt_cum,dt_cum) - enddo -c Declarations pour les fonctions de courant -c print*,'2HISTDEF' - call histdef(fileid,'psi'//nom(iQ) - . ,'stream fn. '//znoml(itot,iQ), - . zunites(itot,iQ),1,jjm,thoriid,llm,1,llm,zvertiid, - . 32,'ave(X)',dt_cum,dt_cum) - enddo - - -c Declarations pour les champs de transport d'air -c print*,'3HISTDEF' - call histdef(fileid, 'masse', 'masse', - . 'kg', 1, jjm, thoriid, llm, 1, llm, zvertiid, - . 32, 'ave(X)', dt_cum, dt_cum) - call histdef(fileid, 'v', 'v', - . 'm/s', 1, jjm, thoriid, llm, 1, llm, zvertiid, - . 32, 'ave(X)', dt_cum, dt_cum) -c Declarations pour les fonctions de courant -c print*,'4HISTDEF' - call histdef(fileid,'psi','stream fn. MMC ','mega t/s', - . 1,jjm,thoriid,llm,1,llm,zvertiid, - . 32,'ave(X)',dt_cum,dt_cum) - - -c Declaration des champs 1D de transport en latitude -c print*,'5HISTDEF' - do iQ=1,nQ - do itr=2,ntr - call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), - . zunites(itr,iQ),1,jjm,thoriid,1,1,1,-99, - . 32,'ave(X)',dt_cum,dt_cum) - enddo - enddo - - -c print*,'8HISTDEF' - CALL histend(fileid) - - - endif - - -c===================================================================== -c Calcul des champs dynamiques -c ---------------------------- - -c énergie cinétique - ucont(:,:,:)=0 - CALL covcont(llm,ucov,vcov,ucont,vcont) - CALL enercin(vcov,ucov,vcont,ucont,ecin) - -c moment cinétique - do l=1,llm - ang(:,:,l)=ucov(:,:,l)+constang(:,:) - unat(:,:,l)=ucont(:,:,l)*cu(:,:) - enddo - - Q(:,:,:,itemp)=teta(:,:,:)*pk(:,:,:)/cpp - Q(:,:,:,igeop)=phi(:,:,:) - Q(:,:,:,iecin)=ecin(:,:,:) - Q(:,:,:,iang)=ang(:,:,:) - Q(:,:,:,iu)=unat(:,:,:) - Q(:,:,:,iovap)=q(:,:,:,1) - Q(:,:,:,iun)=1. - - -c===================================================================== -c Cumul -c===================================================================== -c - if(icum.EQ.0) then - ps_cum=0. - masse_cum=0. - flux_u_cum=0. - flux_v_cum=0. - Q_cum=0. - flux_vQ_cum=0. - flux_uQ_cum=0. - endif - - IF (prt_level > 5) - . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1 - icum=icum+1 - -c accumulation des flux de masse horizontaux - ps_cum=ps_cum+ps - masse_cum=masse_cum+masse - flux_u_cum=flux_u_cum+flux_u - flux_v_cum=flux_v_cum+flux_v - do iQ=1,nQ - Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)+Q(:,:,:,iQ)*masse(:,:,:) - enddo - -c===================================================================== -c FLUX ET TENDANCES -c===================================================================== - -c Flux longitudinal -c ----------------- - do iQ=1,nQ - do l=1,llm - do j=1,jjp1 - do i=1,iim - flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) - s +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ)) - enddo - flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ) - enddo - enddo - enddo - -c flux méridien -c ------------- - do iQ=1,nQ - do l=1,llm - do j=1,jjm - do i=1,iip1 - flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) - s +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ)) - enddo - enddo - enddo - enddo - - -c tendances -c --------- - -c convergence horizontale - call convflu(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ) - -c calcul de la vitesse verticale - call convmas(flux_u_cum,flux_v_cum,convm) - CALL vitvert(convm,w) - - do iQ=1,nQ - do l=1,llm-1 - do j=1,jjp1 - do i=1,iip1 - ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ)) - dQ(i,j,l ,iQ)=dQ(i,j,l ,iQ)-ww - dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww - enddo - enddo - enddo - enddo - IF (prt_level > 5) - . WRITE(lunout,*)'Apres les calculs fait a chaque pas' -c===================================================================== -c PAS DE TEMPS D'ECRITURE -c===================================================================== - if (icum.eq.ncum) then -c===================================================================== - - IF (prt_level > 5) - . WRITE(lunout,*)'Pas d ecriture' - -c Normalisation - do iQ=1,nQ - Q_cum(:,:,:,iQ)=Q_cum(:,:,:,iQ)/masse_cum(:,:,:) - enddo - zz=1./float(ncum) - ps_cum=ps_cum*zz - masse_cum=masse_cum*zz - flux_u_cum=flux_u_cum*zz - flux_v_cum=flux_v_cum*zz - flux_uQ_cum=flux_uQ_cum*zz - flux_vQ_cum=flux_vQ_cum*zz - dQ=dQ*zz - - -c A retravailler eventuellement -c division de dQ par la masse pour revenir aux bonnes grandeurs - do iQ=1,nQ - dQ(:,:,:,iQ)=dQ(:,:,:,iQ)/masse_cum(:,:,:) - enddo - -c===================================================================== -c Transport méridien -c===================================================================== - -c cumul zonal des masses des mailles -c ---------------------------------- - zv=0. - zmasse=0. - call massbar(masse_cum,massebx,masseby) - do l=1,llm - do j=1,jjm - do i=1,iim - zmasse(j,l)=zmasse(j,l)+masseby(i,j,l) - zv(j,l)=zv(j,l)+flux_v_cum(i,j,l) - enddo - zfactv(j,l)=cv(1,j)/zmasse(j,l) - enddo - enddo - -c print*,'3OK' -c -------------------------------------------------------------- -c calcul de la moyenne zonale du transport : -c ------------------------------------------ -c -c -- -c TOT : la circulation totale [ vq ] -c -c - - -c MMC : mean meridional circulation [ v ] [ q ] -c -c ---- -- - - -c TRS : transitoires [ v'q'] = [ vq ] - [ v q ] -c -c - * - * - - - - -c STT : stationaires [ v q ] = [ v q ] - [ v ] [ q ] -c -c - - -c on utilise aussi l'intermediaire TMP : [ v q ] -c -c la variable zfactv transforme un transport meridien cumule -c en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte -c -c -------------------------------------------------------------- - - -c ---------------------------------------- -c Transport dans le plan latitude-altitude -c ---------------------------------------- - - zvQ=0. - psiQ=0. - do iQ=1,nQ - zvQtmp=0. - do l=1,llm - do j=1,jjm -c print*,'j,l,iQ=',j,l,iQ -c Calcul des moyennes zonales du transort total et de zvQtmp - do i=1,iim - zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) - s +flux_vQ_cum(i,j,l,iQ) - zqy= 0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ - s Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l)) - zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy - s /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l))) - zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy - enddo -c print*,'aOK' -c Decomposition - zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l) - zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l) - zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l) - zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l) - zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l) - zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ) - enddo - enddo -c fonction de courant meridienne pour la quantite Q - do l=llm,1,-1 - do j=1,jjm - psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ) - enddo - enddo - enddo - -c fonction de courant pour la circulation meridienne moyenne - psi=0. - do l=llm,1,-1 - do j=1,jjm - psi(j,l)=psi(j,l+1)+zv(j,l) - zv(j,l)=zv(j,l)*zfactv(j,l) - enddo - enddo - -c print*,'4OK' -c sorties proprement dites - if (i_sortie.eq.1) then - do iQ=1,nQ - do itr=1,ntr - call histwrite(fileid,znom(itr,iQ),itau,zvQ(:,:,itr,iQ) - s ,jjm*llm,ndex3d) - enddo - call histwrite(fileid,'psi'//nom(iQ),itau,psiQ(:,1:llm,iQ) - s ,jjm*llm,ndex3d) - enddo - - call histwrite(fileid,'masse',itau,zmasse - s ,jjm*llm,ndex3d) - call histwrite(fileid,'v',itau,zv - s ,jjm*llm,ndex3d) - psi=psi*1.e-9 - call histwrite(fileid,'psi',itau,psi(:,1:llm),jjm*llm,ndex3d) - - endif - - -c ----------------- -c Moyenne verticale -c ----------------- - - zamasse=0. - do l=1,llm - zamasse(:)=zamasse(:)+zmasse(:,l) - enddo - zavQ=0. - do iQ=1,nQ - do itr=2,ntr - do l=1,llm - zavQ(:,itr,iQ)=zavQ(:,itr,iQ)+zvQ(:,l,itr,iQ)*zmasse(:,l) - enddo - zavQ(:,itr,iQ)=zavQ(:,itr,iQ)/zamasse(:) - call histwrite(fileid,'a'//znom(itr,iQ),itau,zavQ(:,itr,iQ) - s ,jjm*llm,ndex3d) - enddo - enddo - -c on doit pouvoir tracer systematiquement la fonction de courant. - -c===================================================================== -c///////////////////////////////////////////////////////////////////// - icum=0 !/////////////////////////////////////// - endif ! icum.eq.ncum !/////////////////////////////////////// -c///////////////////////////////////////////////////////////////////// -c===================================================================== - - return - end Index: LMDZ4/branches/V3_test/libf/dyn3dpar/caladvtrac.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/caladvtrac.F (revision 706) +++ (revision ) @@ -1,142 +1,0 @@ -! -! $Header$ -! -c -c -#ifdef INCA_CH4 - SUBROUTINE caladvtrac(q,pbaru,pbarv , - * p ,masse, dq , teta, - * flxw, - * pk, - * mmt_adj, - * hadv_flg) -#else - SUBROUTINE caladvtrac(q,pbaru,pbarv , - * p ,masse, dq , teta, - * pk) -#endif - -c - IMPLICIT NONE -c -c Auteurs: F.Hourdin , P.Le Van, F.Forget, F.Codron -c -c F.Codron (10/99) : ajout humidite specifique pour eau vapeur -c======================================================================= -c -c Shema de Van Leer -c -c======================================================================= - - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "control.h" -#include "advtrac.h" - -c Arguments: -c ---------- - REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm),masse(ip1jmp1,llm) - REAL p( ip1jmp1,llmp1),q( ip1jmp1,llm,nqmx),dq( ip1jmp1,llm,2 ) - REAL teta( ip1jmp1,llm),pk( ip1jmp1,llm) -#ifdef INCA_CH4 -cym INTEGER :: hadv_flg(nq) - INTEGER :: hadv_flg(nqmx) - REAL :: mmt_adj(iip1,jjp1,llm) - REAL :: flxw(ip1jmp1,llm) -#endif - -c .................................................................. -c -c .. dq n'est utilise et dimensionne que pour l'eau vapeur et liqu. -c -c .................................................................. -c -c Local: -c ------ - - EXTERNAL advtrac,minmaxq, qminimum - INTEGER ij,l, iq, iapptrac - REAL finmasse(ip1jmp1,llm), dtvrtrac - -cc -c -C initialisation - dq = 0. - - CALL SCOPY( 2 * ijp1llm, q, 1, dq, 1 ) - -c test des valeurs minmax -cc CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur (a) ') -cc CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide(a) ') - -c advection - -#ifdef INCA_CH4 - CALL advtrac( pbaru,pbarv, - * p, masse,q,iapptrac, teta, - . flxw, - . pk, - . mmt_adj, - . hadv_flg) -#else - CALL advtrac( pbaru,pbarv, - * p, masse,q,iapptrac, teta, - . pk) -#endif -c - - IF( iapptrac.EQ.iapp_tracvl ) THEN -c -cc CALL minmaxq(q(1,1,1),1.e33,-1.e33,'Eau vapeur ') -cc CALL minmaxq(q(1,1,2),1.e33,-1.e33,'Eau liquide ') - -cc .... Calcul de deltap qu'on stocke dans finmasse ... -c - DO l = 1, llm - DO ij = 1, ip1jmp1 - finmasse(ij,l) = p(ij,l) - p(ij,l+1) - ENDDO - ENDDO - - CALL qminimum( q, 2, finmasse ) - - CALL SCOPY ( ip1jmp1*llm, masse, 1, finmasse, 1 ) - CALL filtreg ( finmasse , jjp1, llm, -2, 2, .TRUE., 1 ) -c -c ***** Calcul de dq pour l'eau , pour le passer a la physique ****** -c ******************************************************************** -c - dtvrtrac = iapp_tracvl * dtvr -c - DO iq = 1 , 2 - DO l = 1 , llm - DO ij = 1,ip1jmp1 - dq(ij,l,iq) = ( q(ij,l,iq) - dq(ij,l,iq) ) * finmasse(ij,l) - * / dtvrtrac - ENDDO - ENDDO - ENDDO -c - ELSE - DO iq = 1 , 2 - DO l = 1, llm - DO ij = 1,ip1jmp1 - dq(ij,l,iq) = 0. - ENDDO - ENDDO - ENDDO - - - ENDIF - -c - -c ... On appelle qminimum uniquement pour l'eau vapeur et liquide .. - - - RETURN - END - - Index: LMDZ4/branches/V3_test/libf/dyn3dpar/caldyn.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/caldyn.F (revision 706) +++ (revision ) @@ -1,122 +1,0 @@ -! -! $Header$ -! -c -c - SUBROUTINE caldyn - $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , - $ phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time ) - - IMPLICIT NONE - -c======================================================================= -c -c Auteur : P. Le Van -c -c Objet: -c ------ -c -c Calcul des tendances dynamiques. -c -c Modif 04/93 F.Forget -c======================================================================= - -c----------------------------------------------------------------------- -c 0. Declarations: -c ---------------- - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" -#include "comgeom.h" - -c Arguments: -c ---------- - - LOGICAL conser - - INTEGER itau - REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) - REAL ps(ip1jmp1),phis(ip1jmp1) - REAL pk(iip1,jjp1,llm),pkf(ip1jmp1,llm) - REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) - REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm) - REAL dv(ip1jm,llm),du(ip1jmp1,llm) - REAL dteta(ip1jmp1,llm),dp(ip1jmp1) - REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) - REAL time - -c Local: -c ------ - - REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1) - REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm) - REAL vorpot(ip1jm,llm) - REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm) - REAL bern(ip1jmp1,llm) - REAL massebxy(ip1jm,llm) - - - INTEGER ij,l - -c----------------------------------------------------------------------- -c Calcul des tendances dynamiques: -c -------------------------------- - - CALL covcont ( llm , ucov , vcov , ucont, vcont ) - CALL pression ( ip1jmp1, ap , bp , ps , p ) - CALL psextbar ( ps , psexbarxy ) - CALL massdair ( p , masse ) - CALL massbar ( masse, massebx , masseby ) - call massbarxy( masse, massebxy ) - CALL flumass ( massebx, masseby , vcont, ucont ,pbaru, pbarv ) - CALL dteta1 ( teta , pbaru , pbarv, dteta ) - CALL convmas ( pbaru, pbarv , convm ) - - DO ij =1, ip1jmp1 - dp( ij ) = convm( ij,1 ) / airesurg( ij ) - ENDDO - - CALL vitvert ( convm , w ) - CALL tourpot ( vcov , ucov , massebxy , vorpot ) - CALL dudv1 ( vorpot , pbaru , pbarv , du , dv ) - CALL enercin ( vcov , ucov , vcont , ucont , ecin ) - CALL bernoui ( ip1jmp1, llm , phi , ecin , bern ) - CALL dudv2 ( teta , pkf , bern , du , dv ) - - - DO l=1,llm - DO ij=1,ip1jmp1 - ang(ij,l) = ucov(ij,l) + constang(ij) - ENDDO - ENDDO - - - CALL advect( ang, vcov, teta, w, massebx, masseby, du, dv,dteta ) - -C WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi -C probablement. Observe sur le code compile avec pgf90 3.0-1 - - DO l = 1, llm - DO ij = 1, ip1jm, iip1 - IF( dv(ij,l).NE.dv(ij+iim,l) ) THEN -c PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov', -c , ' dans caldyn' -c PRINT *,' l, ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l) - dv(ij+iim,l) = dv(ij,l) - endif - enddo - enddo -c----------------------------------------------------------------------- -c Sorties eventuelles des variables de controle: -c ---------------------------------------------- - - IF( conser ) THEN - CALL sortvarc - $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov ) - - ENDIF - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/caldyn0.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/caldyn0.F (revision 706) +++ (revision ) @@ -1,89 +1,0 @@ -! -! $Header$ -! - SUBROUTINE caldyn0 - $ (itau,ucov,vcov,teta,ps,masse,pk,phis , - $ phi,w,pbaru,pbarv,time ) - - IMPLICIT NONE - -c======================================================================= -c -c Auteur : P. Le Van -c -c Objet: -c ------ -c -c Calcul des tendances dynamiques. -c -c Modif 04/93 F.Forget -c======================================================================= - -c----------------------------------------------------------------------- -c 0. Declarations: -c ---------------- - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" -#include "comgeom.h" - -c Arguments: -c ---------- - - INTEGER itau - REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) - REAL ps(ip1jmp1),phis(ip1jmp1) - REAL pk(iip1,jjp1,llm) - REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) - REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm) - REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) - REAL time - -c Local: -c ------ - - REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1) - REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm) - REAL vorpot(ip1jm,llm) - REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm) - REAL bern(ip1jmp1,llm) - REAL massebxy(ip1jm,llm), dp(ip1jmp1) - - - INTEGER ij,l - -c----------------------------------------------------------------------- -c Calcul des tendances dynamiques: -c -------------------------------- - - CALL covcont ( llm , ucov , vcov , ucont, vcont ) - CALL pression ( ip1jmp1, ap , bp , ps , p ) - CALL psextbar ( ps , psexbarxy ) - CALL massdair ( p , masse ) - CALL massbar ( masse, massebx , masseby ) - CALL massbarxy( masse, massebxy ) - CALL flumass ( massebx, masseby , vcont, ucont ,pbaru, pbarv ) - CALL convmas ( pbaru, pbarv , convm ) - - DO ij =1, ip1jmp1 - dp( ij ) = convm( ij,1 ) / airesurg( ij ) - ENDDO - - CALL vitvert ( convm , w ) - CALL tourpot ( vcov , ucov , massebxy , vorpot ) - CALL enercin ( vcov , ucov , vcont , ucont , ecin ) - CALL bernoui ( ip1jmp1, llm , phi , ecin , bern ) - - DO l=1,llm - DO ij=1,ip1jmp1 - ang(ij,l) = ucov(ij,l) + constang(ij) - ENDDO - ENDDO - - CALL sortvarc0 - $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov ) - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/calfis.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/calfis.F (revision 706) +++ (revision ) @@ -1,614 +1,0 @@ -! -! $Header$ -! -C -C - SUBROUTINE calfis(nq, - $ lafin, - $ rdayvrai, - $ heure, - $ pucov, - $ pvcov, - $ pteta, - $ pq, - $ pmasse, - $ pps, - $ pp, - $ ppk, - $ pphis, - $ pphi, - $ pducov, - $ pdvcov, - $ pdteta, - $ pdq, - $ pw, -#ifdef INCA_CH4 - $ flxw, -#endif - $ clesphy0, - $ pdufi, - $ pdvfi, - $ pdhfi, - $ pdqfi, - $ pdpsfi) -c -c Auteur : P. Le Van, F. Hourdin -c ......... - - 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 -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" -#include "temps.h" -#include "advtrac.h" - - INTEGER ngridmx,nq - PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) - -#include "comconst.h" -#include "comvert.h" -#include "comgeom2.h" -#include "control.h" - -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,nqmx) - 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,nqmx) -c - REAL pw(iip1,jjp1,llm) - - 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,nqmx) - REAL pdpsfi(iip1,jjp1) - - INTEGER longcles - PARAMETER ( longcles = 20 ) - REAL clesphy0( longcles ) - - -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) -c - REAL zufi(ngridmx,llm), zvfi(ngridmx,llm) - REAL ztfi(ngridmx,llm),zqfi(ngridmx,llm,nqmx) -c - REAL pcvgu(ngridmx,llm), pcvgv(ngridmx,llm) - REAL pcvgt(ngridmx,llm), pcvgq(ngridmx,llm,2) -c - REAL pvervel(ngridmx,llm) -c - REAL zdufi(ngridmx,llm),zdvfi(ngridmx,llm) - REAL zdtfi(ngridmx,llm),zdqfi(ngridmx,llm,nqmx) - REAL zdpsrf(ngridmx) -c - REAL zsin(iim),zcos(iim),z1(iim) - REAL zsinbis(iim),zcosbis(iim),z1bis(iim) - REAL unskap, pksurcp - -#ifdef INCA_CH4 - REAL flxw(iip1,jjp1,llm) - REAL flxwfi(ngridmx,llm) -#endif -c - - REAL SSUM - - LOGICAL firstcal, debut - DATA firstcal/.true./ - SAVE firstcal,debut - REAL rdayvrai -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 -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 - 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 - ztfi(ig0,l) = pteta(i,j,l) * pksurcp - 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 - ztfi (ig0,l) = pteta(1,jjp1,l) * pksurcp - pcvgt(ig0,l) = pdteta(1,jjp1,l) * pksurcp/ pmasse(1,jjp1,l) - - ENDDO - -c 43.bis traceurs -c --------------- -c - DO iq=1,nq - iiq=niadv(iq) - DO l=1,llm - zqfi(1,l,iq) = pq(1,1,l,iiq) - ig0 = 2 - DO j=2,jjm - DO i = 1, iim - zqfi(ig0,l,iq) = pq(i,j,l,iiq) - ig0 = ig0 + 1 - ENDDO - ENDDO - zqfi(ig0,l,iq) = pq(1,jjp1,l,iiq) - ENDDO - ENDDO - -c convergence dynamique pour les traceurs "EAU" - - 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 - - -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 ( en Pa*m*s ou Kg/s ) .... -c - DO l=1,llm - pvervel(1,l)=pw(1,1,l) * g /apoln - ig0=2 - DO j=2,jjm - DO i = 1, iim - pvervel(ig0,l) = pw(i,j,l) * g * unsaire(i,j) - ig0 = ig0 + 1 - ENDDO - ENDDO - pvervel(ig0,l)=pw(1,jjp1,l) * g /apols - 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) ) - pcvgv(ig0+i,l)= 0.5 * - $ ( 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 - - -#ifdef INCA_CH4 - CALL gr_dyn_fi(llm,iip1,jjp1,ngridmx,flxw,flxwfi) -#endif - - -c----------------------------------------------------------------------- -c Appel de la physique: -c --------------------- - - - CALL physiq (ngridmx, - . llm, - . nq, - . debut, - . lafin, - . rdayvrai, - . heure, - . dtphys, - . zplev, - . zplay, - . zphi, - . zphis, - . presnivs, - . clesphy0, - . zufi, - . zvfi, - . ztfi, - . zqfi, - . pvervel, -#ifdef INCA_CH4 - . flxwfi, -#endif - . zdufi, - . zdvfi, - . zdtfi, - . zdqfi, - . zdpsrf) - -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 --------------------- - - 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. humidite specifique -c --------------------- - - DO iq=1,nqmx - 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 -c ------------ -C initialisation des tendances - pdqfi=0. -C - DO iq=1,nq - 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. - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/convflu.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/convflu.F (revision 706) +++ (revision ) @@ -1,62 +1,0 @@ -! -! $Header$ -! - SUBROUTINE convflu( xflu,yflu,nbniv,convfl ) -c -c P. Le Van -c -c -c ******************************************************************* -c ... calcule la (convergence horiz. * aire locale)du flux ayant pour -c composantes xflu et yflu ,variables extensives . ...... -c ******************************************************************* -c xflu , yflu et nbniv sont des arguments d'entree pour le s-pg .. -c convfl est un argument de sortie pour le s-pg . -c -c njxflu est le nombre de lignes de latitude de xflu, -c ( = jjm ou jjp1 ) -c nbniv est le nombre de niveaux vert. de xflu et de yflu . -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" - REAL xflu,yflu,convfl,convpn,convps - INTEGER l,ij,nbniv - DIMENSION xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) , - * convfl( ip1jmp1,nbniv ) -c - REAL SSUM -c -c -#include "comgeom.h" -c - DO 5 l = 1,nbniv -c - DO 2 ij = iip2, ip1jm - 1 - convfl( ij + 1,l ) = xflu( ij,l ) - xflu( ij + 1,l ) + - * yflu(ij +1,l ) - yflu( ij -iim,l ) - 2 CONTINUE -c -c - -c .... correction pour convfl( 1,j,l) ...... -c .... convfl(1,j,l)= convfl(iip1,j,l) ... -c -CDIR$ IVDEP - DO 3 ij = iip2,ip1jm,iip1 - convfl( ij,l ) = convfl( ij + iim,l ) - 3 CONTINUE -c -c ...... calcul aux poles ....... -c - convpn = SSUM( iim, yflu( 1 ,l ), 1 ) - convps = - SSUM( iim, yflu( ip1jm-iim,l ), 1 ) - DO 4 ij = 1,iip1 - convfl( ij ,l ) = convpn * aire( ij ) / apoln - convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols - 4 CONTINUE -c - 5 CONTINUE - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/convmas.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/convmas.F (revision 706) +++ (revision ) @@ -1,63 +1,0 @@ -! -! $Header$ -! - SUBROUTINE convmas (pbaru, pbarv, convm ) -c - IMPLICIT NONE - -c======================================================================= -c -c Auteurs: P. Le Van , F. Hourdin . -c ------- -c -c Objet: -c ------ -c -c ******************************************************************** -c .... calcul de la convergence du flux de masse aux niveaux p ... -c ******************************************************************** -c -c -c pbaru et pbarv sont des arguments d'entree pour le s-pg .... -c ..... convm est un argument de sortie pour le s-pg .... -c -c le calcul se fait de haut en bas, -c la convergence de masse au niveau p(llm+1) est egale a 0. et -c n'est pas stockee dans le tableau convm . -c -c -c======================================================================= -c -c Declarations: -c ------------- - -#include "dimensions.h" -#include "paramet.h" -#include "comvert.h" -#include "logic.h" - - REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ),convm( ip1jmp1,llm ) - INTEGER l,ij - - -c----------------------------------------------------------------------- -c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... - - CALL convflu( pbaru, pbarv, llm, convm ) - -c----------------------------------------------------------------------- -c filtrage: -c --------- - - CALL filtreg( convm, jjp1, llm, 2, 2, .true., 1 ) - -c integration de la convergence de masse de haut en bas ...... - - DO l = llmm1, 1, -1 - DO ij = 1, ip1jmp1 - convm(ij,l) = convm(ij,l) + convm(ij,l+1) - ENDDO - ENDDO -c - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/covnat.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/covnat.F (revision 706) +++ (revision ) @@ -1,49 +1,0 @@ -! -! $Header$ -! - SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat ) - IMPLICIT NONE - -c======================================================================= -c -c Auteur: F Hourdin Phu LeVan -c ------- -c -c Objet: -c ------ -c -c ********************************************************************* -c calcul des compos. naturelles a partir des comp.covariantes -c ******************************************************************** -c -c======================================================================= - -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - - INTEGER klevel - REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) - REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel ) - INTEGER l,ij - - - DO l = 1,klevel - DO ij = 1, iip1 - unat (ij,l) =0. - END DO - - DO ij = iip2, ip1jm - unat( ij,l ) = ucov( ij,l ) / cu(ij) - ENDDO - DO ij = ip1jm+1, ip1jmp1 - unat (ij,l) =0. - END DO - - DO ij = 1,ip1jm - vnat( ij,l ) = vcov( ij,l ) / cv(ij) - ENDDO - - ENDDO - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/create_etat0_limit.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/create_etat0_limit.F (revision 706) +++ (revision ) @@ -1,46 +1,0 @@ -! -! $Header$ -! - PROGRAM create_etat0_limit -c -c -c Programme d'appel a etat0, creation des etats initiaux et limit_netcdf -c -c -c interbar = .T . si appel a interpol. barycentrique inter_barxy -c -c extrap = .T . si on fait une extrapolation de donnees , comme pour -c les SST lorsque le fichier ne contient pas uniquement des points -c oceaniques . -c -c oldice = .T. si l'on veut garder les anciennes glaces , obtenues -c par grille_m ( grid_atob ) . -c -c on cree le masque dans etat0 que l'on passe ensuite dans limit pour -c garder les cohérences - - LOGICAL interbar, extrap , oldice - PARAMETER ( interbar = .true. , extrap = .FALSE. , oldice=.false.) -#include "dimensions.h" -#include "paramet.h" -#include "indicesol.h" -#include "dimphy.h" - REAL :: masque(iip1,jjp1) - REAL :: pctsrf(klon, nbsrf) - - WRITE(6,*) ' ********************* ' - WRITE(6,*) ' interbar = ',interbar - CALL etat0_netcdf ( interbar, masque, pctsrf ) -c - WRITE(6,1) - WRITE(6,*) ' ********************* ' - WRITE(6,*) ' *** Limit_netcdf *** ' - WRITE(6,*) ' ********************* ' - WRITE(6,1) -c - CALL limit_netcdf ( interbar, extrap , oldice, masque, pctsrf ) - -1 FORMAT(//) - - STOP - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/dissip.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/dissip.F (revision 706) +++ (revision ) @@ -1,143 +1,0 @@ -! -! $Header$ -! - SUBROUTINE dissip( vcov,ucov,teta,p, dv,du,dh ) -c - IMPLICIT NONE - - -c .. Avec nouveaux operateurs star : gradiv2 , divgrad2, nxgraro2 ... -c ( 10/01/98 ) - -c======================================================================= -c -c Auteur: P. Le Van -c ------- -c -c Objet: -c ------ -c -c Dissipation horizontale -c -c======================================================================= -c----------------------------------------------------------------------- -c Declarations: -c ------------- - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comgeom.h" -#include "comdissnew.h" -#include "comdissipn.h" - -c Arguments: -c ---------- - - REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) - REAL p( ip1jmp1,llmp1 ) - REAL dv(ip1jm,llm),du(ip1jmp1,llm),dh(ip1jmp1,llm) - -c Local: -c ------ - - REAL gdx(ip1jmp1,llm),gdy(ip1jm,llm) - REAL grx(ip1jmp1,llm),gry(ip1jm,llm) - REAL te1dt(llm),te2dt(llm),te3dt(llm) - REAL deltapres(ip1jmp1,llm) - - INTEGER l,ij - - REAL SSUM - -c----------------------------------------------------------------------- -c initialisations: -c ---------------- - - DO l=1,llm - te1dt(l) = tetaudiv(l) * dtdiss - te2dt(l) = tetaurot(l) * dtdiss - te3dt(l) = tetah(l) * dtdiss - ENDDO - du=0. - dv=0. - dh=0. - -c----------------------------------------------------------------------- -c Calcul de la dissipation: -c ------------------------- - -c Calcul de la partie grad ( div ) : -c ------------------------------------- - - - IF(lstardis) THEN - CALL gradiv2( llm,ucov,vcov,nitergdiv,gdx,gdy ) - ELSE - CALL gradiv ( llm,ucov,vcov,nitergdiv,gdx,gdy ) - ENDIF - - DO l=1,llm - - DO ij = 1, iip1 - gdx( ij ,l) = 0. - gdx(ij+ip1jm,l) = 0. - ENDDO - - DO ij = iip2,ip1jm - du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l) - ENDDO - DO ij = 1,ip1jm - dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l) - ENDDO - - ENDDO - -c calcul de la partie n X grad ( rot ): -c --------------------------------------- - - IF(lstardis) THEN - CALL nxgraro2( llm,ucov, vcov, nitergrot,grx,gry ) - ELSE - CALL nxgrarot( llm,ucov, vcov, nitergrot,grx,gry ) - ENDIF - - - DO l=1,llm - DO ij = 1, iip1 - grx(ij,l) = 0. - ENDDO - - DO ij = iip2,ip1jm - du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l) - ENDDO - DO ij = 1, ip1jm - dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l) - ENDDO - ENDDO - -c calcul de la partie div ( grad ): -c ----------------------------------- - - - IF(lstardis) THEN - - DO l = 1, llm - DO ij = 1, ip1jmp1 - deltapres(ij,l) = AMAX1( 0., p(ij,l) - p(ij,l+1) ) - ENDDO - ENDDO - - CALL divgrad2( llm,teta, deltapres ,niterh, gdx ) - ELSE - CALL divgrad ( llm,teta, niterh, gdx ) - ENDIF - - DO l = 1,llm - DO ij = 1,ip1jmp1 - dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l ) - ENDDO - ENDDO - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/dteta1.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/dteta1.F (revision 706) +++ (revision ) @@ -1,68 +1,0 @@ -! -! $Header$ -! - SUBROUTINE dteta1 ( teta, pbaru, pbarv, dteta) - IMPLICIT NONE - -c======================================================================= -c -c Auteur: P. Le Van -c ------- -c Modif F.Forget 03/94 (on retire q et dq pour construire dteta1) -c -c ******************************************************************** -c ... calcul du terme de convergence horizontale du flux d'enthalpie -c potentielle ...... -c ******************************************************************** -c .. teta,pbaru et pbarv sont des arguments d'entree pour le s-pg .... -c dteta sont des arguments de sortie pour le s-pg .... -c -c======================================================================= - - -#include "dimensions.h" -#include "paramet.h" -#include "logic.h" - - REAL teta( ip1jmp1,llm ),pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) - REAL dteta( ip1jmp1,llm ) - INTEGER l,ij - - REAL hbyv( ip1jm,llm ), hbxu( ip1jmp1,llm ) - -c - - DO 5 l = 1,llm - - DO 1 ij = iip2, ip1jm - 1 - hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l) + teta(ij+1,l) ) - 1 CONTINUE - -c .... correction pour hbxu(iip1,j,l) ..... -c .... hbxu(iip1,j,l)= hbxu(1,j,l) .... - -CDIR$ IVDEP - DO 2 ij = iip1+ iip1, ip1jm, iip1 - hbxu( ij, l ) = hbxu( ij - iim, l ) - 2 CONTINUE - - - DO 3 ij = 1,ip1jm - hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+ teta(ij +iip1,l) ) - 3 CONTINUE - - 5 CONTINUE - - - CALL convflu ( hbxu, hbyv, llm, dteta ) - - -c stockage dans dh de la convergence horizont. filtree' du flux -c .... ........... -c d'enthalpie potentielle . - - CALL filtreg( dteta, jjp1, llm, 2, 2, .true., 1) - -c - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/dudv1.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/dudv1.F (revision 706) +++ (revision ) @@ -1,53 +1,0 @@ -! -! $Header$ -! - SUBROUTINE dudv1 ( vorpot, pbaru, pbarv, du, dv ) - IMPLICIT NONE -c -c----------------------------------------------------------------------- -c -c Auteur: P. Le Van -c ------- -c -c Objet: -c ------ -c calcul du terme de rotation -c ce terme est ajoute a d(ucov)/dt et a d(vcov)/dt .. -c vorpot, pbaru et pbarv sont des arguments d'entree pour le s-pg .. -c du et dv sont des arguments de sortie pour le s-pg .. -c -c----------------------------------------------------------------------- - -#include "dimensions.h" -#include "paramet.h" - - REAL vorpot( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) , - * pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm ) - INTEGER l,ij -c -c - DO 10 l = 1,llm -c - DO 2 ij = iip2, ip1jm - 1 - du( ij,l ) = 0.125 *( vorpot(ij-iip1, l) + vorpot( ij, l) ) * - * ( pbarv(ij-iip1, l) + pbarv(ij-iim, l) + - * pbarv( ij , l) + pbarv(ij+ 1 , l) ) - 2 CONTINUE -c - DO 3 ij = 1, ip1jm - 1 - dv( ij+1,l ) = - 0.125 *( vorpot(ij, l) + vorpot(ij+1, l) ) * - * ( pbaru(ij, l) + pbaru(ij+1 , l) + - * pbaru(ij+iip1, l) + pbaru(ij+iip2, l) ) - 3 CONTINUE -c -c .... correction pour dv( 1,j,l ) ..... -c .... dv(1,j,l)= dv(iip1,j,l) .... -c -CDIR$ IVDEP - DO 4 ij = 1, ip1jm, iip1 - dv( ij,l ) = dv( ij + iim, l ) - 4 CONTINUE -c - 10 CONTINUE - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/dudv2.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/dudv2.F (revision 706) +++ (revision ) @@ -1,63 +1,0 @@ -! -! $Header$ -! - SUBROUTINE dudv2 ( teta, pkf, bern, du, dv ) - - IMPLICIT NONE -c -c======================================================================= -c -c Auteur: P. Le Van -c ------- -c -c Objet: -c ------ -c -c ***************************************************************** -c ..... calcul du terme de pression (gradient de p/densite ) et -c du terme de ( -gradient de la fonction de Bernouilli ) ... -c ***************************************************************** -c Ces termes sont ajoutes a d(ucov)/dt et a d(vcov)/dt .. -c -c -c teta , pkf, bern sont des arguments d'entree pour le s-pg .... -c du et dv sont des arguments de sortie pour le s-pg .... -c -c======================================================================= -c -#include "dimensions.h" -#include "paramet.h" -#include "comvert.h" - - REAL teta( ip1jmp1,llm ),pkf( ip1jmp1,llm ) ,bern( ip1jmp1,llm ), - * du( ip1jmp1,llm ), dv( ip1jm,llm ) - INTEGER l,ij -c -c - DO 5 l = 1,llm -c - DO 2 ij = iip2, ip1jm - 1 - du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) * - * ( pkf( ij,l ) - pkf(ij+1,l) ) + bern(ij,l) - bern(ij+1,l) - 2 CONTINUE -c -c -c ..... correction pour du(iip1,j,l), j=2,jjm ...... -c ... du(iip1,j,l) = du(1,j,l) ... -c -CDIR$ IVDEP - DO 3 ij = iip1+ iip1, ip1jm, iip1 - du( ij,l ) = du( ij - iim,l ) - 3 CONTINUE -c -c - DO 4 ij = 1,ip1jm - dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) * - * ( pkf(ij+iip1,l) - pkf( ij,l ) ) - * + bern( ij+iip1,l ) - bern( ij ,l ) - 4 CONTINUE -c - 5 CONTINUE -c - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/dynredem.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/dynredem.F (revision 706) +++ (revision ) @@ -1,539 +1,0 @@ -! -! $Header$ -! -c - SUBROUTINE dynredem0(fichnom,iday_end,phis,nq) - USE IOIPSL - IMPLICIT NONE -c======================================================================= -c Ecriture du fichier de redemarrage sous format NetCDF (initialisation) -c======================================================================= -c Declarations: -c ------------- -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" -#include "comgeom.h" -#include "temps.h" -#include "ener.h" -#include "logic.h" -#include "netcdf.inc" -#include "description.h" -#include "serre.h" -#include "advtrac.h" - -c Arguments: -c ---------- - INTEGER iday_end - REAL phis(ip1jmp1) - CHARACTER*(*) fichnom - INTEGER nq - -c Local: -c ------ - INTEGER iq,l - INTEGER length - PARAMETER (length = 100) - REAL tab_cntrl(length) ! tableau des parametres du run - 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 - - REAL zan0,zjulian,hours - INTEGER yyears0,jjour0, mmois0 - character*30 unites - - -c----------------------------------------------------------------------- - modname='dynredem' - - call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) - call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) - - - DO l=1,length - tab_cntrl(l) = 0. - ENDDO - tab_cntrl(1) = FLOAT(iim) - tab_cntrl(2) = FLOAT(jjm) - tab_cntrl(3) = FLOAT(llm) - tab_cntrl(4) = FLOAT(day_ref) - tab_cntrl(5) = FLOAT(annee_ref) - tab_cntrl(6) = rad - tab_cntrl(7) = omeg - tab_cntrl(8) = g - tab_cntrl(9) = cpp - tab_cntrl(10) = kappa - tab_cntrl(11) = daysec - tab_cntrl(12) = dtvr - tab_cntrl(13) = etot0 - tab_cntrl(14) = ptot0 - tab_cntrl(15) = ztot0 - tab_cntrl(16) = stot0 - tab_cntrl(17) = ang0 - tab_cntrl(18) = pa - tab_cntrl(19) = preff -c -c ..... parametres pour le zoom ...... - - tab_cntrl(20) = clon - tab_cntrl(21) = clat - tab_cntrl(22) = grossismx - tab_cntrl(23) = grossismy -c - IF ( fxyhypb ) THEN - tab_cntrl(24) = 1. - tab_cntrl(25) = dzoomx - tab_cntrl(26) = dzoomy - tab_cntrl(27) = 0. - tab_cntrl(28) = taux - tab_cntrl(29) = tauy - ELSE - tab_cntrl(24) = 0. - tab_cntrl(25) = dzoomx - tab_cntrl(26) = dzoomy - tab_cntrl(27) = 0. - tab_cntrl(28) = 0. - tab_cntrl(29) = 0. - IF( ysinus ) tab_cntrl(27) = 1. - ENDIF - - tab_cntrl(30) = FLOAT(iday_end) - tab_cntrl(31) = FLOAT(itau_dyn + itaufin) -c -c ......................................................... -c -c Creation du fichier: -c - ierr = NF_CREATE(fichnom, NF_CLOBBER, nid) - IF (ierr.NE.NF_NOERR) THEN - WRITE(6,*)" Pb d ouverture du fichier "//fichnom - WRITE(6,*)' ierr = ', ierr - CALL ABORT - ENDIF -c -c Preciser quelques attributs globaux: -c - ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, - . "Fichier demmarage 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) - ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid) - 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) - ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) - 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) - ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) - 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) - ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) - 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) - ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) - 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) - ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) - 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) - ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) - 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) - ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) - 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) - ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) - 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) - ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) - 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 - ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) - 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 - ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) - 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 - ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) - 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 - ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) - 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 - ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) - ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, - . "Temps de simulation") - write(unites,200)yyears0,mmois0,jjour0 -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 - ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) - 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 - ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) - 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 - ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) - 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 - IF(nq.GE.1) THEN - DO iq=1,nq - ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) - ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) - ENDDO - ENDIF -c - dims4(1) = idim_rlonv - dims4(2) = idim_rlatu - dims4(3) = idim_s - dims4(4) = idim_tim - ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) - 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 - ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) - ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, - . "Pression au sol") -c - ierr = NF_ENDDEF(nid) ! sortir du mode de definition - ierr = NF_CLOSE(nid) ! fermer le fichier - - PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end - PRINT*,'rad,omeg,g,cpp,kappa', - , rad,omeg,g,cpp,kappa - - RETURN - END - SUBROUTINE dynredem1(fichnom,time, - . vcov,ucov,teta,q,nq,masse,ps) - IMPLICIT NONE -c================================================================= -c Ecriture du fichier de redemarrage sous format NetCDF -c================================================================= -#include "dimensions.h" -#include "paramet.h" -#include "description.h" -#include "netcdf.inc" -#include "comvert.h" -#include "comgeom.h" -#include "advtrac.h" -#include "temps.h" - - INTEGER nq, l - REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) - REAL teta(ip1jmp1,llm) - REAL ps(ip1jmp1),masse(ip1jmp1,llm) - REAL q(ip1jmp1,llm,nq) - CHARACTER*(*) fichnom - - REAL time - INTEGER nid, nvarid - INTEGER ierr - INTEGER iq - INTEGER length - PARAMETER (length = 100) - REAL tab_cntrl(length) ! tableau des parametres du run - character*20 modname - character*80 abort_message -c - INTEGER nb - SAVE nb - DATA nb / 0 / - - modname = 'dynredem1' - ierr = NF_OPEN(fichnom, NF_WRITE, nid) - IF (ierr .NE. NF_NOERR) THEN - PRINT*, "Pb. d ouverture "//fichnom - CALL abort - ENDIF - -c Ecriture/extension de la coordonnee temps - - nb = nb + 1 - 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,nb,time) -#else - ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time) -#endif - PRINT*, "Enregistrement pour ", nb, time - -c -c Re-ecriture du tableau de controle, itaufin n'est plus defini quand -c on passe dans dynredem0 - ierr = NF_INQ_VARID (nid, "controle", nvarid) - IF (ierr .NE. NF_NOERR) THEN - abort_message="dynredem1: Le champ est absent" - ierr = 1 - CALL abort_gcm(modname,abort_message,ierr) - ENDIF -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) -#else - ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) -#endif - tab_cntrl(31) = FLOAT(itau_dyn + itaufin) -#ifdef NC_DOUBLE - ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) -#else - ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) -#endif - -c Ecriture des champs -c - 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 - - IF(nq.GE.1) THEN - do iq=1,nq - 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 - ENDIF -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) -c - RETURN - END - Index: LMDZ4/branches/V3_test/libf/dyn3dpar/etat0_netcdf.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/etat0_netcdf.F (revision 706) +++ (revision ) @@ -1,694 +1,0 @@ -! -! $Header$ -! -c -c - SUBROUTINE etat0_netcdf (interbar, masque, pctsrf) - - USE startvar - USE ioipsl - ! - IMPLICIT NONE - ! -#include "netcdf.inc" -#include "dimensions.h" -#include "paramet.h" - ! - ! -! INTEGER, PARAMETER :: KIDIA=1, KFDIA=iim*(jjm-1)+2, -! .KLON=KFDIA-KIDIA+1,KLEV=llm - ! -#include "comgeom2.h" -#include "comvert.h" -#include "comconst.h" -#include "indicesol.h" -#include "dimphy.h" -#include "dimsoil.h" -#include "temps.h" - ! - LOGICAL interbar - REAL :: latfi(klon), lonfi(klon) - REAL :: orog(iip1,jjp1), rugo(iip1,jjp1), masque(iip1,jjp1), - . psol(iip1, jjp1), phis(iip1, jjp1) - REAL :: p3d(iip1, jjp1, llm+1) - REAL :: uvent(iip1, jjp1, llm) - REAL :: vvent(iip1, jjm, llm) - REAL :: t3d(iip1, jjp1, llm), tpot(iip1, jjp1, llm) - REAL :: q3d(iip1, jjp1, llm,nqmx), qsat(iip1, jjp1, llm) - REAL :: tsol(klon), qsol(klon), sn(klon) - REAL :: tsolsrf(klon,nbsrf), qsolsrf(klon,nbsrf),snsrf(klon,nbsrf) - REAL :: albe(klon,nbsrf), evap(klon,nbsrf) - REAL :: alblw(klon,nbsrf) - REAL :: tsoil(klon,nsoilmx,nbsrf) - REAL :: radsol(klon),rain_fall(klon), snow_fall(klon) - REAL :: solsw(klon), sollw(klon), fder(klon) - REAL :: deltat(klon), frugs(klon,nbsrf), agesno(klon,nbsrf) - REAL :: rugmer(klon) - REAL :: zmea(iip1*jjp1), zstd(iip1*jjp1) - REAL :: zsig(iip1*jjp1), zgam(iip1*jjp1), zthe(iip1*jjp1) - REAL :: zpic(iip1*jjp1), zval(iip1*jjp1), rugsrel(iip1*jjp1) - REAL :: qd(iip1, jjp1, llm) - REAL :: pctsrf(klon, nbsrf) - REAL :: t_ancien(klon,klev), q_ancien(klon,klev) ! - REAL :: run_off_lic_0(klon) - real :: clwcon(klon,klev),rnebcon(klon,klev),ratqs(klon,klev) - ! declarations pour lecture glace de mer - REAL :: rugv(klon) - INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret - INTEGER :: itaul(1), fid - REAL :: lev(1), date - REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic - REAL, ALLOCATABLE, DIMENSION(:) :: dlon_lic, dlat_lic - REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic - REAL :: flic_tmp(iip1, jjp1) - REAL :: champint(iim, jjp1) - ! - - CHARACTER*80 :: varname - ! - INTEGER :: i,j, ig, l, ji,ii1,ii2 - INTEGER :: nq - REAL :: xpi - ! - REAL :: alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm) - REAL :: pk(iip1,jjp1,llm), pls(iip1,jjp1,llm), pks(ip1jmp1) - REAL :: workvar(iip1,jjp1,llm) - ! - REAL :: prefkap, unskap - ! - real :: time_step,t_ops,t_wrt - -#include "comdissnew.h" -#include "control.h" -#include "serre.h" -#include "clesphys.h" - - INTEGER :: longcles - PARAMETER ( longcles = 20 ) - REAL :: clesphy0 ( longcles ) - REAL :: p(iip1,jjp1,llm) - INTEGER :: itau, iday - REAL :: masse(iip1,jjp1,llm) - REAL :: xpn,xps,xppn(iim),xpps(iim) - real :: time - REAL :: phi(ip1jmp1,llm) - REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) - REAL :: w(ip1jmp1,llm) - REAL ::phystep - INTEGER :: radpas - real zrel(iip1*jjp1),chmin,chmax - - CHARACTER*80 :: visu_file - INTEGER :: visuid - -! pour la lecture du fichier masque ocean - integer :: nid_o2a - logical :: couple = .false. - INTEGER :: iml_omask, jml_omask - REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask - REAL, ALLOCATABLE, DIMENSION(:) :: dlon_omask, dlat_omask - REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp - real, dimension(klon) :: ocemask_fi - integer :: isst(klon-2) - real zx_tmp_2d(iim,jjp1) - ! - ! Constantes - ! - pi = 4. * ATAN(1.) - rad = 6371229. - omeg = 4.* ASIN(1.)/(24.*3600.) - g = 9.8 - daysec = 86400. - kappa = 0.2857143 - cpp = 1004.70885 - ! - preff = 101325. - unskap = 1./kappa - ! - jmp1 = jjm + 1 - ! - ! Construct a grid - ! - -! CALL defrun_new(99,.TRUE.,clesphy0) - CALL conf_gcm( 99, .TRUE. , clesphy0 ) - - dtvr = daysec/FLOAT(day_step) - print*,'dtvr',dtvr - - CALL inicons0() - CALL inigeom() - ! - CALL inifilr() - ! - latfi(1) = ASIN(1.0) - DO j = 2, jjm - DO i = 1, iim - latfi((j-2)*iim+1+i)= rlatu(j) - ENDDO - ENDDO - latfi(klon) = - ASIN(1.0) - ! - lonfi(1) = 0.0 - DO j = 2, jjm - DO i = 1, iim - lonfi((j-2)*iim+1+i) = rlonv(i) - ENDDO - ENDDO - lonfi(klon) = 0.0 - ! - xpi = 2.0 * ASIN(1.0) - DO ig = 1, klon - latfi(ig) = latfi(ig) * 180.0 / xpi - lonfi(ig) = lonfi(ig) * 180.0 / xpi - ENDDO - ! - - -C -C En cas de simulation couplee, lecture du masque ocean issu du modele ocean -C utilise pour calculer les poids et pour assurer l'adequation entre les -C fractions d'ocean vu par l'atmosphere et l'ocean. Sinon, on cree le masque -C a partir du fichier relief -C - - write(*,*)'Essai de lecture masque ocean' - iret = nf_open("o2a.nc", NF_NOWRITE, nid_o2a) - if (iret .ne. 0) then - write(*,*)'ATTENTION!! pas de fichier o2a.nc trouve' - write(*,*)'Run force' - varname = 'masque' - masque(:,:) = 0.0 - CALL startget(varname, iip1, jjp1, rlonv, rlatu, masque, 0.0, - , jjm ,rlonu,rlatv , interbar ) - WRITE(*,*) 'MASQUE construit : Masque' - WRITE(*,'(97I1)') nINT(masque(:,:)) - call gr_dyn_fi(1, iip1, jjp1, klon, masque, zmasq) - WHERE (zmasq(1 : klon) .LT. EPSFRA) - zmasq(1 : klon) = 0. - END WHERE - WHERE (1. - zmasq(1 : klon) .LT. EPSFRA) - zmasq(1 : klon) = 1. - END WHERE - else - couple = .true. - iret = nf_close(nid_o2a) - call flininfo("o2a.nc", iml_omask, jml_omask, llm_tmp, ttm_tmp - $ , nid_o2a) - if (iml_omask /= iim .or. jml_omask /= jjp1) then - write(*,*)'Dimensions non compatibles pour masque ocean' - write(*,*)'iim = ',iim,' iml_omask = ',iml_omask - write(*,*)'jjp1 = ',jjp1,' jml_omask = ',jml_omask - stop - endif - ALLOCATE(lat_omask(iml_omask, jml_omask), stat=iret) - ALLOCATE(lon_omask(iml_omask, jml_omask), stat=iret) - ALLOCATE(dlon_omask(iml_omask), stat=iret) - ALLOCATE(dlat_omask(jml_omask), stat=iret) - ALLOCATE(ocemask(iml_omask, jml_omask), stat=iret) - ALLOCATE(ocetmp(iml_omask, jml_omask), stat=iret) - CALL flinopen("o2a.nc", .FALSE., iml_omask, jml_omask, llm_tmp - $ , lon_omask, lat_omask, lev, ttm_tmp, itaul, date, dt, fid) - CALL flinget(fid, 'OceMask', iml_omask, jml_omask, llm_tmp, - $ ttm_tmp, 1, 1, ocetmp) - CALL flinclo(fid) - dlon_omask(1 : iml_omask) = lon_omask(1 : iml_omask, 1) - dlat_omask(1 : jml_omask) = lat_omask(1 , 1 : jml_omask) - ocemask = ocetmp - if (dlat_omask(1) < dlat_omask(jml_omask)) then - do j = 1, jml_omask - ocemask(:,j) = ocetmp(:,jml_omask-j+1) - enddo - endif -C -C passage masque ocean a la grille physique -C - write(*,*)'ocemask ' - write(*,'(96i1)')int(ocemask) - ocemask_fi(1) = ocemask(1,1) - do j = 2, jjm - do i = 1, iim - ocemask_fi((j-2)*iim + i + 1) = ocemask(i,j) - enddo - enddo - ocemask_fi(klon) = ocemask(1,jjp1) - zmasq = 1. - ocemask_fi - endif - - call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) - - varname = 'relief' - ! This line needs to be replaced by a call to restget to get the values in the restart file - orog(:,:) = 0.0 - CALL startget(varname, iip1, jjp1, rlonv, rlatu, orog, 0.0 , - , jjm ,rlonu,rlatv , interbar, masque ) - ! - WRITE(*,*) 'OUT OF GET VARIABLE : Relief' -! WRITE(*,'(49I1)') INT(orog(:,:)) - ! - varname = 'rugosite' - ! This line needs to be replaced by a call to restget to get the values in the restart file - rugo(:,:) = 0.0 - CALL startget(varname, iip1, jjp1, rlonv, rlatu, rugo, 0.0 , - , jjm, rlonu,rlatv , interbar ) - ! - WRITE(*,*) 'OUT OF GET VARIABLE : Rugosite' -! WRITE(*,'(49I1)') INT(rugo(:,:)*10) - ! -C -C on initialise les sous surfaces -C - pctsrf=0. -c - varname = 'psol' - psol(:,:) = 0.0 - CALL startget(varname, iip1, jjp1, rlonv, rlatu, psol, 0.0 , - , jjm ,rlonu,rlatv , interbar ) - ! - ! Compute here the pressure on the intermediate levels. One would expect that this is available in the GCM - ! anyway. - ! -! WRITE(*,*) 'PSOL :', psol(10,20) -! WRITE(*,*) ap(:), bp(:) - CALL pression(ip1jmp1, ap, bp, psol, p3d) -! WRITE(*,*) 'P3D :', p3d(10,20,:) - CALL exner_hyb(ip1jmp1, psol, p3d, alpha, beta, pks, pk, workvar) -! WRITE(*,*) 'PK:', pk(10,20,:) - ! - ! - ! - prefkap = preff ** kappa -! WRITE(*,*) 'unskap, cpp, preff :', unskap, cpp, preff - DO l = 1, llm - DO j=1,jjp1 - DO i =1, iip1 - pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap - ENDDO - ENDDO - ENDDO - ! -! WRITE(*,*) 'PLS :', pls(10,20,:) - ! - varname = 'surfgeo' - phis(:,:) = 0.0 - CALL startget(varname, iip1, jjp1, rlonv, rlatu, phis, 0.0 , - , jjm ,rlonu,rlatv, interbar ) - ! - varname = 'u' - uvent(:,:,:) = 0.0 - CALL startget(varname, iip1, jjp1, rlonu, rlatu, llm, pls, - . workvar, uvent, 0.0, jjm ,rlonv, rlatv, interbar ) - ! - varname = 'v' - vvent(:,:,:) = 0.0 - CALL startget(varname, iip1, jjm, rlonv, rlatv, llm, pls, - . workvar, vvent, 0.0, jjp1, rlonu, rlatu, interbar ) - ! - varname = 't' - t3d(:,:,:) = 0.0 - CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls, - . workvar, t3d, 0.0 , jjm, rlonu, rlatv , interbar ) - ! - WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)), - . maxval(t3d(:,:,:)) - varname = 'tpot' - tpot(:,:,:) = 0.0 - CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls, - . pk, tpot, 0.0 , jjm, rlonu, rlatv , interbar ) - ! - WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)), - . maxval(t3d(:,:,:)) - WRITE(*,*) 'PLS min,max:',minval(pls(:,:,:)), - . maxval(pls(:,:,:)) - -c Calcul de l'humidite a saturation - print*,'avant q_sat' - call q_sat(llm*jjp1*iip1,t3d,pls,qsat) - print*,'apres q_sat' - - WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)), - . maxval(qsat(:,:,:)) - ! - WRITE(*,*) 'QSAT :', qsat(10,20,:) - ! - varname = 'q' - qd(:,:,:) = 0.0 - q3d(:,:,:,:) = 0.0 - WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)), - . maxval(qsat(:,:,:)) - CALL startget(varname, iip1, jjp1, rlonv, rlatu, llm, pls, - . qsat, qd, 0.0, jjm, rlonu, rlatv , interbar ) - q3d(:,:,:,1) = qd(:,:,:) - ! - varname = 'tsol' - ! This line needs to be replaced by a call to restget to get the values in the restart file - tsol(:) = 0.0 - CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, tsol, 0.0, - . jjm, rlonu, rlatv , interbar ) - ! - WRITE(*,*) 'TSOL construit :' -! WRITE(*,'(48I3)') INT(TSOL(2:klon)-273) - ! - varname = 'qsol' - qsol(:) = 0.0 - CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, qsol, 0.0, - . jjm, rlonu, rlatv , interbar ) - ! - varname = 'snow' - sn(:) = 0.0 - CALL startget(varname, iip1, jjp1, rlonv, rlatu, klon, sn, 0.0, - . jjm, rlonu, rlatv , interbar ) - ! - varname = 'rads' - radsol(:) = 0.0 - CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,radsol,0.0, - . jjm, rlonu, rlatv , interbar ) - ! - varname = 'deltat' - deltat(:) = 0.0 - CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,deltat,0.0, - . jjm, rlonu, rlatv , interbar ) - ! - varname = 'rugmer' - rugmer(:) = 0.0 - CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,rugmer,0.0, - . jjm, rlonu, rlatv , interbar ) - ! -! varname = 'agesno' -! agesno(:) = 0.0 -! CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,agesno,0.0, -! . jjm, rlonu, rlatv , interbar ) - - varname = 'zmea' - zmea(:) = 0.0 - CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zmea,0.0, - . jjm, rlonu, rlatv , interbar ) - - varname = 'zstd' - zstd(:) = 0.0 - CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zstd,0.0, - . jjm, rlonu, rlatv , interbar ) - varname = 'zsig' - zsig(:) = 0.0 - CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zsig,0.0, - . jjm, rlonu, rlatv , interbar ) - varname = 'zgam' - zgam(:) = 0.0 - CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zgam,0.0, - . jjm, rlonu, rlatv , interbar ) - varname = 'zthe' - zthe(:) = 0.0 - CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zthe,0.0, - . jjm, rlonu, rlatv , interbar ) - varname = 'zpic' - zpic(:) = 0.0 - CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zpic,0.0, - . jjm, rlonu, rlatv , interbar ) - varname = 'zval' - zval(:) = 0.0 - CALL startget(varname,iip1,jjp1,rlonv,rlatu,klon,zval,0.0, - . jjm, rlonu, rlatv , interbar ) -c - rugsrel(:) = 0.0 - IF(ok_orodr) THEN - DO i = 1, iip1* jjp1 - rugsrel(i) = MAX( 1.e-05, zstd(i)* zsig(i) /2. ) - ENDDO - ENDIF - - -C -C lecture du fichier glace de terre pour fixer la fraction de terre -C et de glace de terre -C - CALL flininfo("landiceref.nc", iml_lic, jml_lic,llm_tmp, ttm_tmp - $ , fid) - ALLOCATE(lat_lic(iml_lic, jml_lic), stat=iret) - ALLOCATE(lon_lic(iml_lic, jml_lic), stat=iret) - ALLOCATE(dlon_lic(iml_lic), stat=iret) - ALLOCATE(dlat_lic(jml_lic), stat=iret) - ALLOCATE(fraclic(iml_lic, jml_lic), stat=iret) - CALL flinopen("landiceref.nc", .FALSE., iml_lic, jml_lic, llm_tmp - $ , lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid) - CALL flinget(fid, 'landice', iml_lic, jml_lic, llm_tmp, ttm_tmp - $ , 1, 1, fraclic) - CALL flinclo(fid) -C -C interpolation sur la grille T du modele -C - WRITE(*,*) 'dimensions de landice iml_lic, jml_lic : ', - $ iml_lic, jml_lic -c -C sil les coordonnees sont en degres, on les transforme -C - IF( MAXVAL( lon_lic(:,:) ) .GT. 2.0 * asin(1.0) ) THEN - lon_lic(:,:) = lon_lic(:,:) * 2.0* ASIN(1.0) / 180. - ENDIF - IF( maxval( lat_lic(:,:) ) .GT. 2.0 * asin(1.0)) THEN - lat_lic(:,:) = lat_lic(:,:) * 2.0 * asin(1.0) / 180. - ENDIF - - dlon_lic(1 : iml_lic) = lon_lic(1 : iml_lic, 1) - dlat_lic(1 : jml_lic) = lat_lic(1 , 1 : jml_lic) -C - CALL grille_m(iml_lic, jml_lic, dlon_lic, dlat_lic, fraclic - $ ,iim, jjp1, - $ rlonv, rlatu, flic_tmp(1 : iim, 1 : jjp1)) -c$$$ flic_tmp(1 : iim, 1 : jjp1) = champint(1: iim, 1 : jjp1) - flic_tmp(iip1, 1 : jjp1) = flic_tmp(1 , 1 : jjp1) -C -C passage sur la grille physique -C - CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp, - $ pctsrf(1:klon, is_lic)) -C adequation avec le maque terre/mer -c zmasq(157) = 0. - WHERE (pctsrf(1 : klon, is_lic) .LT. EPSFRA ) - pctsrf(1 : klon, is_lic) = 0. - END WHERE - WHERE (zmasq( 1 : klon) .LT. EPSFRA) - pctsrf(1 : klon, is_lic) = 0. - END WHERE - pctsrf(1 : klon, is_ter) = zmasq(1 : klon) - DO ji = 1, klon - IF (zmasq(ji) .GT. EPSFRA) THEN - IF ( pctsrf(ji, is_lic) .GE. zmasq(ji)) THEN - pctsrf(ji, is_lic) = zmasq(ji) - pctsrf(ji, is_ter) = 0. - ELSE - pctsrf(ji,is_ter) = zmasq(ji) - pctsrf(ji, is_lic) - IF (pctsrf(ji,is_ter) .LT. EPSFRA) THEN - pctsrf(ji,is_ter) = 0. - pctsrf(ji, is_lic) = zmasq(ji) - ENDIF - ENDIF - ENDIF - END DO -C -C sous surface ocean et glace de mer (pour demarrer on met glace de mer a 0) -C - pctsrf(1 : klon, is_oce) = (1. - zmasq(1 : klon)) - - - WHERE (pctsrf(1 : klon, is_oce) .LT. EPSFRA) - pctsrf(1 : klon, is_oce) = 0. - END WHERE - - if (couple) pctsrf(1 : klon, is_oce) = ocemask_fi(1 : klon) - - isst = 0 - where (pctsrf(2:klon-1,is_oce) >0.) isst = 1 -C -C verif que somme des sous surface = 1 -C - ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf), dim = 2)) - 1.0 ) - $ .GT. EPSFRA) - IF (ji .NE. 0) THEN - WRITE(*,*) 'pb repartition sous maille pour ',ji,' points' - ENDIF - -! where (pctsrf(1:klon, is_ter) >= .5) -! pctsrf(1:klon, is_ter) = 1. -! pctsrf(1:klon, is_oce) = 0. -! pctsrf(1:klon, is_sic) = 0. -! pctsrf(1:klon, is_lic) = 0. -! zmasq = 1. -! endwhere -! where (pctsrf(1:klon, is_lic) >= .5) -! pctsrf(1:klon, is_ter) = 0. -! pctsrf(1:klon, is_oce) = 0. -! pctsrf(1:klon, is_sic) = 0. -! pctsrf(1:klon, is_lic) = 1. -! zmasq = 1. -! endwhere -! where (pctsrf(1:klon, is_oce) >= .5) -! pctsrf(1:klon, is_ter) = 0. -! pctsrf(1:klon, is_oce) = 1. -! pctsrf(1:klon, is_sic) = 0. -! pctsrf(1:klon, is_lic) = 0. -! zmasq = 0. -! endwhere -! where (pctsrf(1:klon, is_sic) >= .5) -! pctsrf(1:klon, is_ter) = 0. -! pctsrf(1:klon, is_oce) = 0. -! pctsrf(1:klon, is_sic) = 1. -! pctsrf(1:klon, is_lic) = 0. -! zmasq = 0. -! endwhere -! call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) -C -C verif que somme des sous surface = 1 -C -! ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf), dim = 2)) - 1.0 ) -! $ .GT. EPSFRA) -! IF (ji .NE. 0) THEN -! WRITE(*,*) 'pb repartition sous maille pour ',ji,' points' -! ENDIF - - CALL gr_fi_ecrit(1,klon,iim,jjp1,zmasq,zx_tmp_2d) - write(*,*)'zmasq = ' - write(*,'(96i1)')nint(zx_tmp_2d) - call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) - WRITE(*,*) 'MASQUE construit : Masque' - WRITE(*,'(97I1)') nINT(masque(:,:)) - - - -C Calcul intermediaire -c - CALL massdair( p3d, masse ) -c - - print *,' ALPHAX ',alphax - - DO l = 1, llm - DO i = 1, iim - xppn(i) = aire( i, 1 ) * masse( i , 1 , l ) - xpps(i) = aire( i,jjp1 ) * masse( i , jjp1 , l ) - ENDDO - xpn = SUM(xppn)/apoln - xps = SUM(xpps)/apols - DO i = 1, iip1 - masse( i , 1 , l ) = xpn - masse( i , jjp1 , l ) = xps - ENDDO - ENDDO - q3d(iip1,:,:,:) = q3d(1,:,:,:) - phis(iip1,:) = phis(1,:) - -C init pour traceurs - call iniadvtrac(nq) -C Ecriture - CALL inidissip( lstardis, nitergdiv, nitergrot, niterh , - * tetagdiv, tetagrot , tetatemp ) - print*,'sortie inidissip' - itau = 0 - itau_dyn = 0 - itau_phy = 0 - iday = dayref +itau/day_step - time = FLOAT(itau-(iday-dayref)*day_step)/day_step -c - IF(time.GT.1) THEN - time = time - 1 - iday = iday + 1 - ENDIF - day_ref = dayref - annee_ref = anneeref - - CALL geopot ( ip1jmp1, tpot , pk , pks, phis , phi ) - print*,'sortie geopot' - - CALL caldyn0 ( itau,uvent,vvent,tpot,psol,masse,pk,phis , - * phi,w, pbaru,pbarv,time+iday-dayref ) - print*,'sortie caldyn0' - CALL dynredem0("start.nc",dayref,phis,nqmx) - print*,'sortie dynredem0' - CALL dynredem1("start.nc",0.0,vvent,uvent,tpot,q3d,nqmx,masse , - . psol) - print*,'sortie dynredem1' -C -C Ecriture etat initial physique -C - write(*,*)'phystep ',dtvr,iphysiq,nbapp_rad - phystep = dtvr * FLOAT(iphysiq) - radpas = NINT (86400./phystep/ FLOAT(nbapp_rad) ) - write(*,*)'phystep =', phystep, radpas -cIM : lecture de co2_ppm & solaire ds physiq.def -c co2_ppm = 348.0 -c solaire = 1365.0 - -c -c Initialisation -c tsol, qsol, sn,albe, evap,tsoil,rain_fall, snow_fall,solsw, sollw,frugs -c - tsolsrf(:,is_ter) = tsol - tsolsrf(:,is_lic) = tsol - tsolsrf(:,is_oce) = tsol - tsolsrf(:,is_sic) = tsol - snsrf(:,is_ter) = sn - snsrf(:,is_lic) = sn - snsrf(:,is_oce) = sn - snsrf(:,is_sic) = sn - albe(:,is_ter) = 0.08 - albe(:,is_lic) = 0.6 - albe(:,is_oce) = 0.5 - albe(:,is_sic) = 0.6 - alblw = albe - evap(:,:) = 0. - qsolsrf(:,is_ter) = 150 - qsolsrf(:,is_lic) = 150 - qsolsrf(:,is_oce) = 150. - qsolsrf(:,is_sic) = 150. - do i = 1, nbsrf - do j = 1, nsoilmx - tsoil(:,j,i) = tsol - enddo - enddo - rain_fall = 0.; snow_fall = 0. - solsw = 165. - sollw = -53. - t_ancien = 273.15 - q_ancien = 0. - agesno = 0. - deltat = 0. - frugs(1:klon,is_oce) = rugmer(1:klon) - frugs(1:klon,is_ter) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0) - frugs(1:klon,is_lic) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0) - frugs(1:klon,is_sic) = 0.001 - fder = 0.0 - clwcon = 0.0 - rnebcon = 0.0 - ratqs = 0.0 - run_off_lic_0 = 0.0 - -cIM call phyredem("startphy.nc",phystep,radpas, co2_ppm, solaire, - call phyredem("startphy.nc",phystep,radpas, - $ latfi, lonfi, pctsrf, tsolsrf, tsoil, deltat, qsolsrf, qsol, - $ snsrf, - $ albe, alblw, evap, rain_fall, snow_fall, solsw, sollw, fder, - $ radsol, frugs, agesno, - $ zmea, zstd, zsig, zgam, zthe, zpic, zval, rugsrel, - $ t_ancien, q_ancien, rnebcon, ratqs, clwcon, - $ run_off_lic_0) - print*,'sortie phyredem' - -C Sortie Visu pour les champs dynamiques - if (1.eq.0 ) then - print*,'sortie visu' - time_step = 1. - t_ops = 2. - t_wrt = 2. - itau = 2. - visu_file='Etat0_visu.nc' - CALL initdynav(visu_file,dayref,anneeref,time_step, - . t_ops, t_wrt, nqmx, visuid) - CALL writedynav(visuid, nqmx, itau,vvent , - . uvent,tpot,pk,phi,q3d,masse,psol,phis) - else - print*,'CCCCCCCCCCCCCCCCCC REACTIVER SORTIE VISU DANS ETAT0' - endif - print*,'entree histclo' - CALL histclo - RETURN - ! - END SUBROUTINE etat0_netcdf Index: LMDZ4/branches/V3_test/libf/dyn3dpar/flumass.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/flumass.F (revision 706) +++ (revision ) @@ -1,109 +1,0 @@ -! -! $Header$ -! - SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv ) - - IMPLICIT NONE - -c======================================================================= -c -c Auteurs: P. Le Van, F. Hourdin . -c ------- -c -c Objet: -c ------ -c -c ********************************************************************* -c .... calcul du flux de masse aux niveaux s ...... -c ********************************************************************* -c massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg . -c pbaru et pbarv sont des argum.de sortie pour le s-pg . -c -c======================================================================= - - -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - - REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) , - * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ), - * pbarv( ip1jm,llm ) - - REAL apbarun( iip1 ),apbarus( iip1 ) - - REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0 - INTEGER l,ij,i - - REAL SSUM - - - DO 5 l = 1,llm - - DO 1 ij = iip2,ip1jm - pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l ) - 1 CONTINUE - - DO 3 ij = 1,ip1jm - pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l ) - 3 CONTINUE - - 5 CONTINUE - -c ................................................................ -c calcul de la composante du flux de masse en x aux poles ....... -c ................................................................ -c par la resolution d'1 systeme de 2 equations . - -c la premiere equat.decrivant le calcul de la divergence en 1 point i -c du pole,ce calcul etant itere de i=1 a i=im . -c c.a.d , -c ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i) = -c - somme de ( pbarv(n) )/aire pole - -c l'autre equat.specifiant que la moyenne du flux de masse au pole est =0. -c c.a.d somme de pbaru(n)*aire locale(n) = 0. - -c on en revient ainsi a determiner la constante additive commune aux pbaru -c qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt -c i=1 . -c i variant de 1 a im -c n variant de 1 a im - - sairen = SSUM( iim, aire( 1 ), 1 ) - saireun= SSUM( iim, aireu( 1 ), 1 ) - saires = SSUM( iim, aire( ip1jm+1 ), 1 ) - saireus= SSUM( iim, aireu( ip1jm+1 ), 1 ) - - DO 20 l = 1,llm - - ctn = SSUM( iim, pbarv( 1 ,l), 1 )/ sairen - cts = SSUM( iim, pbarv(ip1jmi1+ 1,l), 1 )/ saires - - pbaru( 1 ,l )= pbarv( 1 ,l ) - ctn * aire( 1 ) - pbaru( ip1jm+1,l )= - pbarv( ip1jmi1+1,l ) + cts * aire( ip1jm+1 ) - - DO 11 i = 2,iim - pbaru( i ,l ) = pbaru( i - 1 ,l ) + - * pbarv( i ,l ) - ctn * aire( i ) - - pbaru( i+ ip1jm,l ) = pbaru( i+ ip1jm-1,l ) - - * pbarv( i+ ip1jmi1,l ) + cts * aire(i+ ip1jm) - 11 CONTINUE - DO 12 i = 1,iim - apbarun(i) = aireu( i ) * pbaru( i , l) - apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l) - 12 CONTINUE - ctn0 = -SSUM( iim,apbarun,1 )/saireun - cts0 = -SSUM( iim,apbarus,1 )/saireus - DO 14 i = 1,iim - pbaru( i , l) = 2. * ( pbaru( i , l) + ctn0 ) - pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 ) - 14 CONTINUE - - pbaru( iip1 ,l ) = pbaru( 1 ,l ) - pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l ) - 20 CONTINUE - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/fluxstokenc.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/fluxstokenc.F (revision 706) +++ (revision ) @@ -1,155 +1,0 @@ - SUBROUTINE fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, - . time_step,itau ) - - USE IOIPSL -c -c Auteur : F. Hourdin -c -c -ccc .. Modif. P. Le Van ( 20/12/97 ) ... -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" -#include "comgeom.h" -#include "tracstoke.h" -#include "temps.h" - - REAL time_step,t_wrt, t_ops - REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) - REAL masse(ip1jmp1,llm),teta(ip1jmp1,llm),phi(ip1jmp1,llm) - REAL phis(ip1jmp1) - - REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm) - REAL massem(ip1jmp1,llm),tetac(ip1jmp1,llm),phic(ip1jmp1,llm) - - REAL pbarug(ip1jmp1,llm),pbarvg(iip1,jjm,llm),wg(ip1jmp1,llm) - - REAL pbarvst(iip1,jjp1,llm),zistdyn - real dtcum - - INTEGER iadvtr,ndex(1) - integer nscal - real tst(1),ist(1),istp(1) - INTEGER ij,l,irec,i,j,itau - INTEGER fluxid, fluxvid,fluxdid - - SAVE iadvtr, massem,pbaruc,pbarvc,irec - SAVE phic,tetac - logical first - save first - data first/.true./ - DATA iadvtr/0/ - - if(first) then - - CALL initfluxsto( 'fluxstoke', - . time_step,istdyn* time_step,istdyn* time_step, - . nqmx, fluxid,fluxvid,fluxdid) - - ndex(1) = 0 - call histwrite(fluxid, 'phis', 1, phis, iip1*jjp1, ndex) - call histwrite(fluxid, 'aire', 1, aire, iip1*jjp1, ndex) - - ndex(1) = 0 - nscal = 1 - tst(1) = time_step - call histwrite(fluxdid, 'dtvr', 1, tst, nscal, ndex) - ist(1)=istdyn - call histwrite(fluxdid, 'istdyn', 1, ist, nscal, ndex) - istp(1)= istphy - call histwrite(fluxdid, 'istphy', 1, istp, nscal, ndex) - - first = .false. - - endif - - - IF(iadvtr.EQ.0) THEN - CALL initial0(ijp1llm,phic) - CALL initial0(ijp1llm,tetac) - CALL initial0(ijp1llm,pbaruc) - CALL initial0(ijmllm,pbarvc) - ENDIF - -c accumulation des flux de masse horizontaux - DO l=1,llm - DO ij = 1,ip1jmp1 - pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) - tetac(ij,l) = tetac(ij,l) + teta(ij,l) - phic(ij,l) = phic(ij,l) + phi(ij,l) - ENDDO - DO ij = 1,ip1jm - pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) - ENDDO - ENDDO - -c selection de la masse instantannee des mailles avant le transport. - IF(iadvtr.EQ.0) THEN - CALL SCOPY(ip1jmp1*llm,masse,1,massem,1) - ENDIF - - iadvtr = iadvtr+1 - - -c Test pour savoir si on advecte a ce pas de temps - IF ( iadvtr.EQ.istdyn ) THEN -c normalisation - DO l=1,llm - DO ij = 1,ip1jmp1 - pbaruc(ij,l) = pbaruc(ij,l)/float(istdyn) - tetac(ij,l) = tetac(ij,l)/float(istdyn) - phic(ij,l) = phic(ij,l)/float(istdyn) - ENDDO - DO ij = 1,ip1jm - pbarvc(ij,l) = pbarvc(ij,l)/float(istdyn) - ENDDO - ENDDO - -c traitement des flux de masse avant advection. -c 1. calcul de w -c 2. groupement des mailles pres du pole. - - CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) - - do l=1,llm - do j=1,jjm - do i=1,iip1 - pbarvst(i,j,l)=pbarvg(i,j,l) - enddo - enddo - do i=1,iip1 - pbarvst(i,jjp1,l)=0. - enddo - enddo - - iadvtr=0 - Print*,'ITAU auqel on stoke les fluxmasses',itau - - call histwrite(fluxid, 'masse', itau, massem, - . iip1*jjp1*llm, ndex) - - call histwrite(fluxid, 'pbaru', itau, pbarug, - . iip1*jjp1*llm, ndex) - - call histwrite(fluxvid, 'pbarv', itau, pbarvg, - . iip1*jjm*llm, ndex) - - call histwrite(fluxid, 'w' ,itau, wg, - . iip1*jjp1*llm, ndex) - - call histwrite(fluxid, 'teta' ,itau, tetac, - . iip1*jjp1*llm, ndex) - - call histwrite(fluxid, 'phi' ,itau, phic, - . iip1*jjp1*llm, ndex) - -C - - ENDIF ! if iadvtr.EQ.istdyn - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/friction.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/friction.F (revision 706) +++ (revision ) @@ -1,99 +1,0 @@ -! -! $Header$ -! -c======================================================================= - SUBROUTINE friction(ucov,vcov,pdt) - IMPLICIT NONE - -c======================================================================= -c -c -c Objet: -c ------ -c -c *********** -c Friction -c *********** -c -c======================================================================= - -#include "dimensions.h" -#include "paramet.h" -#include "comgeom2.h" -#include "control.h" -#include "comconst.h" - - REAL pdt - REAL modv(iip1,jjp1),zco,zsi - REAL vpn,vps,upoln,upols,vpols,vpoln - REAL u2(iip1,jjp1),v2(iip1,jjm) - REAL ucov( iip1,jjp1,llm ),vcov( iip1,jjm,llm ) - INTEGER i,j - REAL cfric - parameter (cfric=1.e-5) - - -c calcul des composantes au carre du vent naturel - do j=1,jjp1 - do i=1,iip1 - u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j) - enddo - enddo - do j=1,jjm - do i=1,iip1 - v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j) - enddo - enddo - -c calcul du module de V en dehors des poles - do j=2,jjm - do i=2,iip1 - modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j))) - enddo - modv(1,j)=modv(iip1,j) - enddo - -c les deux composantes du vent au pole sont obtenues comme -c premiers modes de fourier de v pres du pole - upoln=0. - vpoln=0. - upols=0. - vpols=0. - do i=2,iip1 - zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) - zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) - vpn=vcov(i,1,1)/cv(i,1) - vps=vcov(i,jjm,1)/cv(i,jjm) - upoln=upoln+zco*vpn - vpoln=vpoln+zsi*vpn - upols=upols+zco*vps - vpols=vpols+zsi*vps - enddo - vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi - vps=sqrt(upols*upols+vpols*vpols)/pi - do i=1,iip1 -c modv(i,1)=vpn -c modv(i,jjp1)=vps - modv(i,1)=modv(i,2) - modv(i,jjp1)=modv(i,jjm) - enddo - -c calcul du frottement au sol. - do j=2,jjm - do i=1,iim - ucov(i,j,1)=ucov(i,j,1) - s -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1) - enddo - ucov(iip1,j,1)=ucov(1,j,1) - enddo - do j=1,jjm - do i=1,iip1 - vcov(i,j,1)=vcov(i,j,1) - s -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1) - enddo - vcov(iip1,j,1)=vcov(1,j,1) - enddo - - RETURN - END - Index: LMDZ4/branches/V3_test/libf/dyn3dpar/gr_u_scal.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/gr_u_scal.F (revision 706) +++ (revision ) @@ -1,60 +1,0 @@ -! -! $Header$ -! - SUBROUTINE gr_u_scal(nx,x_u,x_scal) -c%W% %G% -c======================================================================= -c -c Author: Frederic Hourdin original: 11/11/92 -c ------- -c -c Subject: -c ------ -c -c Method: -c -------- -c -c Interface: -c ---------- -c -c Input: -c ------ -c -c Output: -c ------- -c -c======================================================================= - IMPLICIT NONE -c----------------------------------------------------------------------- -c Declararations: -c --------------- - -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - -c Arguments: -c ---------- - - INTEGER nx - REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx) - -c Local: -c ------ - - INTEGER l,ij - -c----------------------------------------------------------------------- - - DO l=1,nx - DO ij=ip1jmp1,2,-1 - x_scal(ij,l)= - s (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) - s /(aireu(ij)+aireu(ij-1)) - ENDDO - ENDDO - - CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1) - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/gr_v_scal.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/gr_v_scal.F (revision 706) +++ (revision ) @@ -1,64 +1,0 @@ -! -! $Header$ -! - SUBROUTINE gr_v_scal(nx,x_v,x_scal) -c%W% %G% -c======================================================================= -c -c Author: Frederic Hourdin original: 11/11/92 -c ------- -c -c Subject: -c ------ -c -c Method: -c -------- -c -c Interface: -c ---------- -c -c Input: -c ------ -c -c Output: -c ------- -c -c======================================================================= - IMPLICIT NONE -c----------------------------------------------------------------------- -c Declararations: -c --------------- - -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - -c Arguments: -c ---------- - - INTEGER nx - REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx) - -c Local: -c ------ - - INTEGER l,ij - -c----------------------------------------------------------------------- - - DO l=1,nx - DO ij=iip2,ip1jm - x_scal(ij,l)= - s (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) - s /(airev(ij-iip1)+airev(ij)) - ENDDO - DO ij=1,iip1 - x_scal(ij,l)=0. - ENDDO - DO ij=ip1jm+1,ip1jmp1 - x_scal(ij,l)=0. - ENDDO - ENDDO - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/groupe.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/groupe.F (revision 706) +++ (revision ) @@ -1,97 +1,0 @@ -! -! $Header$ -! - subroutine groupe(pext,pbaru,pbarv,pbarum,pbarvm,wm) - implicit none - -c sous-programme servant a fitlrer les champs de flux de masse aux -c poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur -c et a mesure qu'on se rapproche du pole. -c -c en entree: pext, pbaru et pbarv -c -c en sortie: pbarum,pbarvm et wm. -c -c remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc -c pas besoin de w en entree. - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comgeom2.h" -#include "comvert.h" - - integer ngroup - parameter (ngroup=3) - - - real pbaru(iip1,jjp1,llm),pbarv(iip1,jjm,llm) - real pext(iip1,jjp1,llm) - - real pbarum(iip1,jjp1,llm),pbarvm(iip1,jjm,llm) - real wm(iip1,jjp1,llm) - - real zconvm(iip1,jjp1,llm),zconvmm(iip1,jjp1,llm) - - real uu - - integer i,j,l - - logical firstcall - save firstcall - - data firstcall/.true./ - - if (firstcall) then - if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre ede point' - firstcall=.false. - endif - -c Champs 1D - - call convflu(pbaru,pbarv,llm,zconvm) - -c - call scopy(ijp1llm,zconvm,1,zconvmm,1) - call scopy(ijmllm,pbarv,1,pbarvm,1) - -c - call groupeun(jjp1,llm,zconvmm) - call groupeun(jjm,llm,pbarvm) - -c Champs 3D - - do l=1,llm - do j=2,jjm - uu=pbaru(iim,j,l) - do i=1,iim - uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l) - pbarum(i,j,l)=uu -c zconvm(i,j,l ) = xflu(i-1,j,l)-xflu(i,j,l)+ -c * yflu(i,j,l)-yflu(i,j-1,l) - enddo - pbarum(iip1,j,l)=pbarum(1,j,l) - enddo - enddo - -c integration de la convergence de masse de haut en bas ...... - do l=1,llm - do j=1,jjp1 - do i=1,iip1 - zconvmm(i,j,l)=zconvmm(i,j,l) - enddo - enddo - enddo - do l = llm-1,1,-1 - do j=1,jjp1 - do i=1,iip1 - zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1) - enddo - enddo - enddo - - CALL vitvert(zconvmm,wm) - - return - end - Index: LMDZ4/branches/V3_test/libf/dyn3dpar/groupeun.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/groupeun.F (revision 706) +++ (revision ) @@ -1,60 +1,0 @@ -! -! $Header$ -! - subroutine groupeun(jjmax,llmax,q) - implicit none - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comgeom2.h" - - integer jjmax,llmax - real q(iip1,jjmax,llmax) - - integer ngroup - parameter (ngroup=3) - - real airen,airecn,qn - real aires,airecs,qs - - integer i,j,l,ig,j1,j2,i0,jd - -Champs 3D - jd=jjp1-jjmax - do l=1,llm - j1=1+jd - j2=2 - do ig=1,ngroup - do j=j1-jd,j2-jd -c print*,'groupe ',ig,' j= ',j,2**(ngroup-ig+1),'pts groupes' - do i0=1,iim,2**(ngroup-ig+1) - airen=0. - airecn=0. - qn=0. - aires=0. - airecs=0. - qs=0. - do i=i0,i0+2**(ngroup-ig+1)-1 - airen=airen+aire(i,j) - aires=aires+aire(i,jjp1-j+1) - qn=qn+q(i,j,l) - qs=qs+q(i,jjp1-j+1-jd,l) - enddo - airecn=0. - airecs=0. - do i=i0,i0+2**(ngroup-ig+1)-1 - q(i,j,l)=qn*aire(i,j)/airen - q(i,jjp1-j+1-jd,l)=qs*aire(i,jjp1-j+1)/aires - enddo - enddo - q(iip1,j,l)=q(1,j,l) - q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l) - enddo - j1=j2+1 - j2=j2+2**ig - enddo - enddo - - return - end Index: LMDZ4/branches/V3_test/libf/dyn3dpar/guide.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/guide.F (revision 706) +++ (revision ) @@ -1,500 +1,0 @@ -! -! $Header$ -! - subroutine guide(itau,ucov,vcov,teta,q,masse,ps) - - IMPLICIT NONE - -c ...... Version du 10/01/98 .......... - -c avec coordonnees verticales hybrides -c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) - -c======================================================================= -c -c Auteur: F.Hourdin -c ------- -c -c Objet: -c ------ -c -c GCM LMD nouvelle grille -c -c======================================================================= - -c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv -c et possibilite d'appeler une fonction f(y) a derivee tangente -c hyperbolique a la place de la fonction a derivee sinusoidale. - -c ... Possibilite de choisir le shema de Van-leer pour l'advection de -c q , en faisant iadv = 10 dans traceur (29/04/97) . -c -c----------------------------------------------------------------------- -c Declarations: -c ------------- - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comdissnew.h" -#include "comvert.h" -#include "comgeom.h" -#include "logic.h" -#include "temps.h" -#include "control.h" -#include "ener.h" -#include "netcdf.inc" -#include "description.h" -#include "serre.h" -#include "tracstoke.h" -#include "guide.h" - - -c variables dynamiques - REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants - REAL teta(ip1jmp1,llm) ! temperature potentielle - REAL q(ip1jmp1,llm) ! temperature potentielle - REAL ps(ip1jmp1) ! pression au sol - REAL masse(ip1jmp1,llm) ! masse d'air - -c common passe pour des sorties - real dxdys(iip1,jjp1),dxdyu(iip1,jjp1),dxdyv(iip1,jjm) - common/comdxdy/dxdys,dxdyu,dxdyv - -c variables dynamiques pour les reanalyses. - REAL ucovrea1(ip1jmp1,llm),vcovrea1(ip1jm,llm) !vts cov reas - REAL tetarea1(ip1jmp1,llm) ! temp pot reales - REAL qrea1(ip1jmp1,llm) ! temp pot reales - REAL masserea1(ip1jmp1,llm) ! masse - REAL psrea1(ip1jmp1) ! ps - REAL ucovrea2(ip1jmp1,llm),vcovrea2(ip1jm,llm) !vts cov reas - REAL tetarea2(ip1jmp1,llm) ! temp pot reales - REAL qrea2(ip1jmp1,llm) ! temp pot reales - REAL masserea2(ip1jmp1,llm) ! masse - REAL psrea2(ip1jmp1) ! ps - real latmin - - real alpha_q(ip1jmp1) - real alpha_T(ip1jmp1),alpha_P(ip1jmp1) - real alpha_u(ip1jmp1),alpha_v(ip1jm) - real dday_step,toto,reste,itau_test - INTEGER step_rea,count_no_rea - - real aire_min,aire_max - integer ilon,ilat - real factt,ztau(ip1jmp1) - - INTEGER itau,ij,l,i,j - integer ncidt,varidpl,nlev,status - integer rcod,rid - real ditau,tau,a - save nlev - -c TEST SUR QSAT - real p(ip1jmp1,llmp1),pk(ip1jmp1,llm),pks(ip1jmp1) - real pkf(ip1jmp1,llm) - real pres(ip1jmp1,llm) - REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) - - real qsat(ip1jmp1,llm) - real unskap - real tnat(ip1jmp1,llm) -ccccccccccccccccc - - - LOGICAL first - save first - data first/.true./ - - save ucovrea1,vcovrea1,tetarea1,masserea1,psrea1,qrea1 - save ucovrea2,vcovrea2,tetarea2,masserea2,psrea2,qrea2 - - save alpha_T,alpha_q,alpha_u,alpha_v,alpha_P,itau_test - save step_rea,count_no_rea - - character*10 file - integer igrads - real dtgrads - save igrads,dtgrads - data igrads,dtgrads/2,100./ - -C----------------------------------------------------------------------- -c calcul de l'humidite saturante -C----------------------------------------------------------------------- - print*,'OK0' - CALL pression( ip1jmp1, ap, bp, ps, p ) - call massdair(p,masse) - print*,'OK1' - CALL exner_hyb(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf) - print*,'OK2' - tnat(:,:)=pk(:,:)*teta(:,:)/cpp - print*,'OK3' - unskap = 1./ kappa - pres(:,:)=preff*(pk(:,:)/cpp)**unskap - print*,'OK4' - call q_sat(iip1*jjp1*llm,tnat,pres,qsat) - -C----------------------------------------------------------------------- - -c----------------------------------------------------------------------- -c initialisations pour la lecture des reanalyses. -c alpha determine la part des injections de donnees a chaque etape -c alpha=1 signifie pas d'injection -c alpha=0 signifie injection totale -c----------------------------------------------------------------------- - - print*,'ONLINE=',online - if(online.eq.-1) then - return - endif - - if (first) then - - print*,'initialisation du guide ' - call conf_guide - print*,'apres conf_guide' - - file='guide' - call inigrads(igrads,iip1 - s ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi - s ,llm,presnivs,1. - s ,dtgrads,file,'dyn_zon ') - - print* - s ,'1: en-ligne, 0: hors-ligne (x=x_rea), -1: climat (x=x_gcm)' - - if(online.eq.-1) return - if (online.eq.1) then - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c Constantes de temps de rappel en jour -c 0.1 c'est en gros 2h30. -c 1e10 est une constante infinie donc en gros pas de guidage -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c coordonnees du centre du zoom - call coordij(clon,clat,ilon,ilat) -c aire de la maille au centre du zoom - aire_min=aire(ilon+(ilat-1)*iip1) -c aire maximale de la maille - aire_max=0. - do ij=1,ip1jmp1 - aire_max=max(aire_max,aire(ij)) - enddo -C factt = pas de temps en fraction de jour - factt=dtvr*iperiod/daysec - -c subroutine tau2alpha(type,im,jm,factt,taumin,taumax,alpha) - call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v) - call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u) - call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T) - call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P) - call tau2alpha(1,iip1,jjp1,factt,tau_min_q,tau_max_q,alpha_q) - - call dump2d(iip1,jjp1,aire,'AIRE MAILLe ') - call dump2d(iip1,jjp1,alpha_u,'COEFF U ') - call dump2d(iip1,jjp1,alpha_T,'COEFF T ') - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c Cas ou on force exactement par les variables analysees - else - alpha_T=0. - alpha_u=0. - alpha_v=0. - alpha_P=0. -c physic=.false. - endif - - itau_test=1001 - step_rea=1 - count_no_rea=0 - -c itau_test montre si l'importation a deja ete faite au rang itau -c lecture d'un fichier netcdf pour determiner le nombre de niveaux - ncidt=NCOPN('T.nc',NCNOWRIT,rcod) - if (ncep) then - status=NF_INQ_DIMID(ncidt,'LEVEL',rid) - else - status=NF_INQ_DIMID(ncidt,'PRESSURE',rid) - endif - status=NF_INQ_DIMLEN(ncidt,rid,nlev) - print *,'nlev', nlev - call ncclos(ncidt,rcod) -c Lecture du premier etat des reanalyses. - call read_reanalyse(1,ps - s ,ucovrea2,vcovrea2,tetarea2,qrea2,masserea2,psrea2,1,nlev) - qrea2(:,:)=max(qrea2(:,:),0.1) - - -c----------------------------------------------------------------------- -c Debut de l'integration temporelle: -c ---------------------------------- - - endif ! first -c -C----------------------------------------------------------------------- -C----- IMPORTATION DES VENTS,PRESSION ET TEMPERATURE REELS: -C----------------------------------------------------------------------- - - ditau=real(itau) - DDAY_step=real(day_step) - write(*,*)'ditau,dday_step' - write(*,*)ditau,dday_step - toto=4*ditau/dday_step - reste=toto-aint(toto) -c write(*,*)'toto,reste',toto,reste - - if (reste.eq.0.) then - if (itau_test.eq.itau) then - write(*,*)'deuxieme passage de advreel a itau=',itau - stop - else - vcovrea1(:,:)=vcovrea2(:,:) - ucovrea1(:,:)=ucovrea2(:,:) - tetarea1(:,:)=tetarea2(:,:) - qrea1(:,:)=qrea2(:,:) - - print*,'LECTURE REANALYSES, pas ',step_rea - s ,'apres ',count_no_rea,' non lectures' - step_rea=step_rea+1 - itau_test=itau - call read_reanalyse(step_rea,ps - s ,ucovrea2,vcovrea2,tetarea2,qrea2,masserea2,psrea2,1,nlev) - qrea2(:,:)=max(qrea2(:,:),0.1) - factt=dtvr*iperiod/daysec - ztau(:)=factt/max(alpha_T(:),1.e-10) - call wrgrads(igrads,1,aire ,'aire ','aire ' ) - call wrgrads(igrads,1,dxdys ,'dxdy ','dxdy ' ) - call wrgrads(igrads,1,alpha_u,'au ','au ' ) - call wrgrads(igrads,1,alpha_T,'at ','at ' ) - call wrgrads(igrads,1,ztau,'taut ','taut ' ) - call wrgrads(igrads,llm,ucov,'u ','u ' ) - call wrgrads(igrads,llm,ucovrea2,'ua ','ua ' ) - call wrgrads(igrads,llm,teta,'T ','T ' ) - call wrgrads(igrads,llm,tetarea2,'Ta ','Ta ' ) - call wrgrads(igrads,llm,qrea2,'Qa ','Qa ' ) - call wrgrads(igrads,llm,q,'Q ','Q ' ) - - call wrgrads(igrads,llm,qsat,'QSAT ','QSAT ' ) - - endif - else - count_no_rea=count_no_rea+1 - endif - -C----------------------------------------------------------------------- -c Guidage -c x_gcm = a * x_gcm + (1-a) * x_reanalyses -C----------------------------------------------------------------------- - - if(ini_anal) print*,'ATTENTION !!! ON PART DU GUIDAGE' - - ditau=real(itau) - dday_step=real(day_step) - - - tau=4*ditau/dday_step - tau=tau-aint(tau) - - print*,'ATTENTION !!!! ON NE GUIDE QUE JUSQU A 15N' - -c ucov - if (guide_u) then - do l=1,llm - do ij=1,ip1jmp1 - a=(1.-tau)*ucovrea1(ij,l)+tau*ucovrea2(ij,l) - ucov(ij,l)=(1.-alpha_u(ij))*ucov(ij,l)+alpha_u(ij)*a - if (first.and.ini_anal) ucov(ij,l)=a - enddo - enddo - endif - -c teta - if (guide_T) then - do l=1,llm - do ij=1,ip1jmp1 - a=(1.-tau)*tetarea1(ij,l)+tau*tetarea2(ij,l) - teta(ij,l)=(1.-alpha_T(ij))*teta(ij,l)+alpha_T(ij)*a - if (first.and.ini_anal) teta(ij,l)=a - enddo - enddo - endif - -c P - if (guide_P) then - do ij=1,ip1jmp1 - a=(1.-tau)*psrea1(ij)+tau*psrea2(ij) - ps(ij)=(1.-alpha_P(ij))*ps(ij)+alpha_P(ij)*a - if (first.and.ini_anal) ps(ij)=a - enddo - CALL pression(ip1jmp1,ap,bp,ps,p) - CALL massdair(p,masse) - endif - - -c q - if (guide_Q) then - do l=1,llm - do ij=1,ip1jmp1 - a=(1.-tau)*qrea1(ij,l)+tau*qrea2(ij,l) -c hum relative en % -> hum specif - a=qsat(ij,l)*a*0.01 - q(ij,l)=(1.-alpha_Q(ij))*q(ij,l)+alpha_Q(ij)*a - if (first.and.ini_anal) q(ij,l)=a - enddo - enddo - endif - -c vcov - if (guide_v) then - do l=1,llm - do ij=1,ip1jm - a=(1.-tau)*vcovrea1(ij,l)+tau*vcovrea2(ij,l) - vcov(ij,l)=(1.-alpha_v(ij))*vcov(ij,l)+alpha_v(ij)*a - if (first.and.ini_anal) vcov(ij,l)=a - enddo - if (first.and.ini_anal) vcov(ij,l)=a - enddo - endif - -c call dump2d(iip1,jjp1,tetarea1,'TETA REA 1 ') -c call dump2d(iip1,jjp1,tetarea2,'TETA REA 2 ') -c call dump2d(iip1,jjp1,teta,'TETA ') - - first=.false. - - return - end - -c======================================================================= - subroutine tau2alpha(type,pim,pjm,factt,taumin,taumax,alpha) -c======================================================================= - - implicit none - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comgeom2.h" -#include "guide.h" -#include "serre.h" - -c arguments : - integer type - integer pim,pjm - real factt,taumin,taumax,dxdymin,dxdymax - real dxdy_,alpha(pim,pjm) - real dxdy_min,dxdy_max - -c local : - real alphamin,alphamax,gamma,xi - save gamma - integer i,j,ilon,ilat - - logical first - save first - data first/.true./ - - real cus(iip1,jjp1),cvs(iip1,jjp1) - real cuv(iip1,jjm),cvu(iip1,jjp1) - real zdx(iip1,jjp1),zdy(iip1,jjp1) - - real zlat - real dxdys(iip1,jjp1),dxdyu(iip1,jjp1),dxdyv(iip1,jjm) - common/comdxdy/dxdys,dxdyu,dxdyv - - if (first) then - do j=2,jjm - do i=2,iip1 - zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j)) - enddo - zdx(1,j)=zdx(iip1,j) - enddo - do j=2,jjm - do i=1,iip1 - zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j)) - enddo - enddo - do i=1,iip1 - zdx(i,1)=zdx(i,2) - zdx(i,jjp1)=zdx(i,jjm) - zdy(i,1)=zdy(i,2) - zdy(i,jjp1)=zdy(i,jjm) - enddo - do j=1,jjp1 - do i=1,iip1 - dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j)) - enddo - enddo - do j=1,jjp1 - do i=1,iim - dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j)) - enddo - dxdyu(iip1,j)=dxdyu(1,j) - enddo - do j=1,jjm - do i=1,iip1 - dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j)) - enddo - enddo - - call dump2d(iip1,jjp1,dxdys,'DX2DY2 SCAL ') - call dump2d(iip1,jjp1,dxdyu,'DX2DY2 U ') - call dump2d(iip1,jjp1,dxdyv,'DX2DY2 v ') - -c coordonnees du centre du zoom - call coordij(clon,clat,ilon,ilat) -c aire de la maille au centre du zoom - dxdy_min=dxdys(ilon,ilat) -c dxdy maximale de la maille - dxdy_max=0. - do j=1,jjp1 - do i=1,iip1 - dxdy_max=max(dxdy_max,dxdys(i,j)) - enddo - enddo - - if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then - print*,'ATTENTION modele peu zoome' - print*,'ATTENTION on prend une constante de guidage cste' - gamma=0. - else - gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min) - print*,'gamma=',gamma - if (gamma.lt.1.e-5) then - print*,'gamma =',gamma,'<1e-5' - stop - endif - print*,'gamma=',gamma - gamma=log(0.5)/log(gamma) - endif - endif - - alphamin=factt/taumax - alphamax=factt/taumin - - do j=1,pjm - do i=1,pim - if (type.eq.1) then - dxdy_=dxdys(i,j) - zlat=rlatu(j)*180./pi - elseif (type.eq.2) then - dxdy_=dxdyu(i,j) - zlat=rlatu(j)*180./pi - elseif (type.eq.3) then - dxdy_=dxdyv(i,j) - zlat=rlatv(j)*180./pi - endif - xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma -c pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin - xi=min(xi,1.) - if(lat_min_guide.le.zlat .and. zlat.le.lat_max_guide) then - alpha(i,j)=xi*alphamin+(1.-xi)*alphamax - else - alpha(i,j)=0. - endif - enddo - enddo - - - return - end Index: LMDZ4/branches/V3_test/libf/dyn3dpar/integrd.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/integrd.F (revision 706) +++ (revision ) @@ -1,232 +1,0 @@ -! -! $Header$ -! - SUBROUTINE integrd - $ ( nq,vcovm1,ucovm1,tetam1,psm1,massem1, - $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis,finvmaold ) - - IMPLICIT NONE - - -c======================================================================= -c -c Auteur: P. Le Van -c ------- -c -c objet: -c ------ -c -c Incrementation des tendances dynamiques -c -c======================================================================= -c----------------------------------------------------------------------- -c Declarations: -c ------------- - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comgeom.h" -#include "comvert.h" -#include "logic.h" -#include "temps.h" -#include "serre.h" -#include "advtrac.h" - -c Arguments: -c ---------- - - INTEGER nq - - REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) - REAL q(ip1jmp1,llm,nq) - REAL ps(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1) - - REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) - REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm) - - REAL dv(ip1jm,llm),du(ip1jmp1,llm) - REAL dteta(ip1jmp1,llm),dp(ip1jmp1) - REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm) - -c Local: -c ------ - - REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1) - REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm) - REAL p(ip1jmp1,llmp1) - REAL tpn,tps,tppn(iim),tpps(iim) - REAL qpn,qps,qppn(iim),qpps(iim) - REAL deltap( ip1jmp1,llm ) - - INTEGER l,ij,iq - - REAL SSUM - -c----------------------------------------------------------------------- - - DO l = 1,llm - DO ij = 1,iip1 - ucov( ij , l) = 0. - ucov( ij +ip1jm, l) = 0. - uscr( ij ) = 0. - uscr( ij +ip1jm ) = 0. - ENDDO - ENDDO - - -c ............ integration de ps .............. - - CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1) - - DO 2 ij = 1,ip1jmp1 - pscr (ij) = ps(ij) - ps (ij) = psm1(ij) + dt * dp(ij) - 2 CONTINUE -c - DO ij = 1,ip1jmp1 - IF( ps(ij).LT.0. ) THEN - PRINT*,' Au point ij = ',ij, ' , pression sol neg. ', ps(ij) - STOP' dans integrd' - ENDIF - ENDDO -c - DO ij = 1, iim - tppn(ij) = aire( ij ) * ps( ij ) - tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm) - ENDDO - tpn = SSUM(iim,tppn,1)/apoln - tps = SSUM(iim,tpps,1)/apols - DO ij = 1, iip1 - ps( ij ) = tpn - ps(ij+ip1jm) = tps - ENDDO -c -c ... Calcul de la nouvelle masse d'air au dernier temps integre t+1 ... -c - CALL pression ( ip1jmp1, ap, bp, ps, p ) - CALL massdair ( p , masse ) - - CALL SCOPY( ijp1llm , masse, 1, finvmasse, 1 ) - CALL filtreg( finvmasse, jjp1, llm, -2, 2, .TRUE., 1 ) -c - -c ............ integration de ucov, vcov, h .............. - - DO 10 l = 1,llm - - DO 4 ij = iip2,ip1jm - uscr( ij ) = ucov( ij,l ) - ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l ) - 4 CONTINUE - - DO 5 ij = 1,ip1jm - vscr( ij ) = vcov( ij,l ) - vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l ) - 5 CONTINUE - - DO 6 ij = 1,ip1jmp1 - hscr( ij ) = teta(ij,l) - teta ( ij,l ) = tetam1(ij,l) * massem1(ij,l) / masse(ij,l) - $ + dt * dteta(ij,l) / masse(ij,l) - 6 CONTINUE - -c .... Calcul de la valeur moyenne, unique aux poles pour teta ...... -c -c - DO ij = 1, iim - tppn(ij) = aire( ij ) * teta( ij ,l) - tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) - ENDDO - tpn = SSUM(iim,tppn,1)/apoln - tps = SSUM(iim,tpps,1)/apols - - DO ij = 1, iip1 - teta( ij ,l) = tpn - teta(ij+ip1jm,l) = tps - ENDDO -c - - IF(leapf) THEN - CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 ) - CALL SCOPY ( ip1jm, vscr(1), 1, vcovm1(1, l), 1 ) - CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 ) - END IF - - 10 CONTINUE - - -c -c ....... integration de q ...... -c -c$$$ IF( iadv(1).NE.3.AND.iadv(2).NE.3 ) THEN -c$$$c -c$$$ IF( forward. OR . leapf ) THEN -c$$$ DO iq = 1,2 -c$$$ DO l = 1,llm -c$$$ DO ij = 1,ip1jmp1 -c$$$ q(ij,l,iq) = ( q(ij,l,iq)*finvmaold(ij,l) + dtvr *dq(ij,l,iq) )/ -c$$$ $ finvmasse(ij,l) -c$$$ ENDDO -c$$$ ENDDO -c$$$ ENDDO -c$$$ ELSE -c$$$ DO iq = 1,2 -c$$$ DO l = 1,llm -c$$$ DO ij = 1,ip1jmp1 -c$$$ q( ij,l,iq ) = q( ij,l,iq ) * finvmaold(ij,l) / finvmasse(ij,l) -c$$$ ENDDO -c$$$ ENDDO -c$$$ ENDDO -c$$$ -c$$$ END IF -c$$$c -c$$$ ENDIF - - DO l = 1, llm - DO ij = 1, ip1jmp1 - deltap(ij,l) = p(ij,l) - p(ij,l+1) - ENDDO - ENDDO - - CALL qminimum( q, nq, deltap ) -c -c ..... Calcul de la valeur moyenne, unique aux poles pour q ..... -c - - DO iq = 1, nq - DO l = 1, llm - - DO ij = 1, iim - qppn(ij) = aire( ij ) * q( ij ,l,iq) - qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq) - ENDDO - qpn = SSUM(iim,qppn,1)/apoln - qps = SSUM(iim,qpps,1)/apols - - DO ij = 1, iip1 - q( ij ,l,iq) = qpn - q(ij+ip1jm,l,iq) = qps - ENDDO - - ENDDO - ENDDO - - - CALL SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 ) -c -c -c ..... FIN de l'integration de q ....... - -15 continue - -c ................................................................. - - - IF( leapf ) THEN - CALL SCOPY ( ip1jmp1 , pscr , 1, psm1 , 1 ) - CALL SCOPY ( ip1jmp1*llm, massescr, 1, massem1, 1 ) - END IF - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/leapfrog.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/leapfrog.F (revision 706) +++ (revision ) @@ -1,668 +1,0 @@ -! -! $Header$ -! -c -c - SUBROUTINE leapfrog(ucov,vcov,teta,ps,masse,phis,nq,q,clesphy0, - & time_0) - - USE misc_mod - USE write_field -#ifdef INCA - USE transport_controls, ONLY : hadv_flg, mmt_adj -#endif - - IMPLICIT NONE - -c ...... Version du 10/01/98 .......... - -c avec coordonnees verticales hybrides -c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) - -c======================================================================= -c -c Auteur: P. Le Van /L. Fairhead/F.Hourdin -c ------- -c -c Objet: -c ------ -c -c GCM LMD nouvelle grille -c -c======================================================================= -c -c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv -c et possibilite d'appeler une fonction f(y) a derivee tangente -c hyperbolique a la place de la fonction a derivee sinusoidale. - -c ... Possibilite de choisir le shema pour l'advection de -c q , en modifiant iadv dans traceur.def (10/02) . -c -c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) -c Pour Van-Leer iadv=10 -c -c----------------------------------------------------------------------- -c Declarations: -c ------------- - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comdissnew.h" -#include "comvert.h" -#include "comgeom.h" -#include "logic.h" -#include "temps.h" -#include "control.h" -#include "ener.h" -#include "description.h" -#include "serre.h" -#include "com_io_dyn.h" -#include "iniprint.h" - -c#include "tracstoke.h" - -#include "academic.h" - - integer nq - - INTEGER longcles - PARAMETER ( longcles = 20 ) - REAL clesphy0( longcles ) - - real zqmin,zqmax - INTEGER nbetatmoy, nbetatdem,nbetat - -c variables dynamiques - REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants - REAL teta(ip1jmp1,llm) ! temperature potentielle - REAL q(ip1jmp1,llm,nqmx) ! champs advectes - REAL ps(ip1jmp1) ! pression au sol - REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches - REAL pks(ip1jmp1) ! exner au sol - REAL pk(ip1jmp1,llm) ! exner au milieu des couches - REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches - REAL masse(ip1jmp1,llm) ! masse d'air - REAL phis(ip1jmp1) ! geopotentiel au sol - REAL phi(ip1jmp1,llm) ! geopotentiel - REAL w(ip1jmp1,llm) ! vitesse verticale - -c variables dynamiques intermediaire pour le transport - REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse - -c variables dynamiques au pas -1 - REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) - REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1) - REAL massem1(ip1jmp1,llm) - -c tendances dynamiques - REAL dv(ip1jm,llm),du(ip1jmp1,llm) - REAL dteta(ip1jmp1,llm),dq(ip1jmp1,llm,nqmx),dp(ip1jmp1) - -c tendances de la dissipation - REAL dvdis(ip1jm,llm),dudis(ip1jmp1,llm) - REAL dtetadis(ip1jmp1,llm) - -c tendances physiques - REAL dvfi(ip1jm,llm),dufi(ip1jmp1,llm) - REAL dtetafi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqmx),dpfi(ip1jmp1) - -c variables pour le fichier histoire - REAL dtav ! intervalle de temps elementaire - - REAL tppn(iim),tpps(iim),tpn,tps -c - INTEGER itau,itaufinp1,iav - INTEGER*4 iday ! jour julien - REAL time ! Heure de la journee en fraction d'1 jour - - REAL SSUM - REAL time_0 , finvmaold(ip1jmp1,llm) - -cym LOGICAL lafin - LOGICAL :: lafin=.false. - INTEGER ij,iq,l - INTEGER ik - - real time_step, t_wrt, t_ops - - REAL rdayvrai,rdaym_ini - LOGICAL first,callinigrads - - data callinigrads/.true./ - character*10 string10 - - REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) -#ifdef INCA_CH4 - REAL :: flxw(ip1jmp1,llm) -#endif - -c+jld variables test conservation energie - REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) -C Tendance de la temp. potentiel d (theta)/ d t due a la -C tansformation d'energie cinetique en energie thermique -C cree par la dissipation - REAL dtetaecdt(ip1jmp1,llm) - REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) - REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) - REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec - CHARACTER*15 ztit - INTEGER ip_ebil_dyn ! PRINT level for energy conserv. diag. - SAVE ip_ebil_dyn - DATA ip_ebil_dyn/0/ -c-jld - - character*80 dynhist_file, dynhistave_file - character*20 modname - character*80 abort_message - -C Calendrier - LOGICAL true_calendar - PARAMETER (true_calendar = .false.) - - logical dissip_conservative - save dissip_conservative - data dissip_conservative/.true./ - - LOGICAL prem - save prem - DATA prem/.true./ - INTEGER testita - PARAMETER (testita = 9) - - itaufin = nday*day_step - itaufinp1 = itaufin +1 - - - itau = 0 - iday = day_ini+itau/day_step - time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 - IF(time.GT.1.) THEN - time = time-1. - iday = iday+1 - ENDIF - - -c----------------------------------------------------------------------- -c On initialise la pression et la fonction d'Exner : -c -------------------------------------------------- - - dq=0. - CALL pression ( ip1jmp1, ap, bp, ps, p ) - CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) - -c----------------------------------------------------------------------- -c Debut de l'integration temporelle: -c ---------------------------------- - - 1 CONTINUE - - -#ifdef CPP_IOIPSL - if (ok_guide.and.(itaufin-itau-1)*dtvr.gt.21600) then - call guide(itau,ucov,vcov,teta,q,masse,ps) - else - IF(prt_level>9)WRITE(*,*)'attention on ne guide pas les ', - . '6 dernieres heures' - endif -#endif -c -c IF( MOD( itau, 10* day_step ).EQ.0 ) THEN -c CALL test_period ( ucov,vcov,teta,q,p,phis ) -c PRINT *,' ---- Test_period apres continue OK ! -----', itau -c ENDIF -c - CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 ) - CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 ) - CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 ) - CALL SCOPY( ijp1llm,masse, 1, massem1, 1 ) - CALL SCOPY( ip1jmp1, ps , 1, psm1 , 1 ) - - forward = .TRUE. - leapf = .FALSE. - dt = dtvr - -c ... P.Le Van .26/04/94 .... - - CALL SCOPY ( ijp1llm, masse, 1, finvmaold, 1 ) - CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 ) - - call minmax(ijp1llm,q(:,:,3),zqmin,zqmax) - - 2 CONTINUE - -c----------------------------------------------------------------------- - -c date: -c ----- - - -c gestion des appels de la physique et des dissipations: -c ------------------------------------------------------ -c -c ... P.Le Van ( 6/02/95 ) .... - - apphys = .FALSE. - statcl = .FALSE. - conser = .FALSE. - apdiss = .FALSE. - - IF( purmats ) THEN - IF( MOD(itau,iconser) .EQ.0.AND. forward ) conser = .TRUE. - IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE. - IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward - s .and. iflag_phys.NE.0 ) apphys = .TRUE. - ELSE - IF( MOD(itau ,iconser) .EQ. 0 ) conser = .TRUE. - IF( MOD(itau+1,idissip) .EQ. 0 ) apdiss = .TRUE. - IF( MOD(itau+1,iphysiq).EQ.0.AND.iflag_phys.NE.0) apphys=.TRUE. - END IF - -c----------------------------------------------------------------------- -c calcul des tendances dynamiques: -c -------------------------------- - - CALL geopot ( ip1jmp1, teta , pk , pks, phis , phi ) - - CALL caldyn - $ ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , - $ phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time+iday-day_ini ) - -c----------------------------------------------------------------------- -c calcul des tendances advection des traceurs (dont l'humidite) -c ------------------------------------------------------------- - - IF( forward. OR . leapf ) THEN - -c -#ifdef INCA_CH4 - CALL caladvtrac(q,pbaru,pbarv, - * p, masse, dq, teta, - . flxw, - . pk, - . mmt_adj, - . hadv_flg) -#else - CALL caladvtrac(q,pbaru,pbarv, - * p, masse, dq, teta, - . pk) -#endif - - IF (offline) THEN -Cmaf stokage du flux de masse pour traceurs OFF-LINE - -#ifdef CPP_IOIPSL - CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, - . dtvr, itau) -#endif - - - ENDIF -c - ENDIF - - -c----------------------------------------------------------------------- -c integrations dynamique et traceurs: -c ---------------------------------- - - - CALL integrd ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 , - $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis , - $ finvmaold ) - - -c .P.Le Van (26/04/94 ajout de finvpold dans l'appel d'integrd) -c -c----------------------------------------------------------------------- -c calcul des tendances physiques: -c ------------------------------- -c ######## P.Le Van ( Modif le 6/02/95 ) ########### -c - IF( purmats ) THEN - IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE. - ELSE - IF( itau+1. EQ. itaufin ) lafin = .TRUE. - ENDIF -c -c - IF( apphys ) THEN -c -c ....... Ajout P.Le Van ( 17/04/96 ) ........... -c - - CALL pression ( ip1jmp1, ap, bp, ps, p ) - CALL exner_hyb( ip1jmp1, ps, p,alpha,beta,pks, pk, pkf ) - - rdaym_ini = itau * dtvr / daysec - rdayvrai = rdaym_ini + day_ini - - -c rajout debug -c lafin = .true. - - -c Inbterface avec les routines de phylmd (phymars ... ) -c ----------------------------------------------------- - -#ifdef CPP_PHYS -c+jld - -c Diagnostique de conservation de l'énergie : initialisation - IF (ip_ebil_dyn.ge.1 ) THEN - ztit='bil dyn' - CALL diagedyn(ztit,2,1,1,dtphys - e , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) - ENDIF -c-jld - - CALL calfis( nq, lafin ,rdayvrai,time , - $ ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , - $ du,dv,dteta,dq,w, -#ifdef INCA_CH4 - $ flxw, -#endif - $ clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi ) - -c ajout des tendances physiques: -c ------------------------------ - CALL addfi( nqmx, dtphys, leapf, forward , - $ ucov, vcov, teta , q ,ps , - $ dufi, dvfi, dtetafi , dqfi ,dpfi ) -c -c Diagnostique de conservation de l'énergie : difference - IF (ip_ebil_dyn.ge.1 ) THEN - ztit='bil phys' - CALL diagedyn(ztit,2,1,1,dtphys - e , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) - ENDIF -#else - -c Calcul academique de la physique = Rappel Newtonien + fritcion -c -------------------------------------------------------------- - teta(:,:)=teta(:,:) - s -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel - call friction(ucov,vcov,iphysiq*dtvr) - -#endif - -c-jld - ENDIF - - CALL pression ( ip1jmp1, ap, bp, ps, p ) - CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) - - -c----------------------------------------------------------------------- -c dissipation horizontale et verticale des petites echelles: -c ---------------------------------------------------------- - - IF(apdiss) THEN - - -c calcul de l'energie cinetique avant dissipation - call covcont(llm,ucov,vcov,ucont,vcont) - call enercin(vcov,ucov,vcont,ucont,ecin0) - -c dissipation - CALL dissip(vcov,ucov,teta,p,dvdis,dudis,dtetadis) - ucov=ucov+dudis - vcov=vcov+dvdis -c teta=teta+dtetadis - - -c------------------------------------------------------------------------ - if (dissip_conservative) then -C On rajoute la tendance due a la transform. Ec -> E therm. cree -C lors de la dissipation - call covcont(llm,ucov,vcov,ucont,vcont) - call enercin(vcov,ucov,vcont,ucont,ecin) - dtetaecdt= (ecin0-ecin)/ pk -c teta=teta+dtetaecdt - dtetadis=dtetadis+dtetaecdt - endif - teta=teta+dtetadis -c------------------------------------------------------------------------ - - -c ....... P. Le Van ( ajout le 17/04/96 ) ........... -c ... Calcul de la valeur moyenne, unique de h aux poles ..... -c - - DO l = 1, llm - DO ij = 1,iim - tppn(ij) = aire( ij ) * teta( ij ,l) - tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) - ENDDO - tpn = SSUM(iim,tppn,1)/apoln - tps = SSUM(iim,tpps,1)/apols - - DO ij = 1, iip1 - teta( ij ,l) = tpn - teta(ij+ip1jm,l) = tps - ENDDO - ENDDO - - DO ij = 1,iim - tppn(ij) = aire( ij ) * ps ( ij ) - tpps(ij) = aire(ij+ip1jm) * ps (ij+ip1jm) - ENDDO - tpn = SSUM(iim,tppn,1)/apoln - tps = SSUM(iim,tpps,1)/apols - - DO ij = 1, iip1 - ps( ij ) = tpn - ps(ij+ip1jm) = tps - ENDDO - - - END IF - -c ajout debug -c IF( lafin ) then -c abort_message = 'Simulation finished' -c call abort_gcm(modname,abort_message,0) -c ENDIF - -c ******************************************************************** -c ******************************************************************** -c .... fin de l'integration dynamique et physique pour le pas itau .. -c ******************************************************************** -c ******************************************************************** - -c preparation du pas d'integration suivant ...... -cym call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/))) -cym call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/))) - - IF (itau==itaumax) then - RETURN - ENDIF - - IF ( .NOT.purmats ) THEN -c ........................................................ -c .............. schema matsuno + leapfrog .............. -c ........................................................ - - IF(forward. OR. leapf) THEN - itau= itau + 1 - iday= day_ini+itau/day_step - time= FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 - IF(time.GT.1.) THEN - time = time-1. - iday = iday+1 - ENDIF - ENDIF - - - IF( itau. EQ. itaufinp1 ) then -c$$$ write(79,*) 'ucov',ucov -c$$$ write(80,*) 'vcov',vcov -c$$$ write(81,*) 'teta',teta -c$$$ write(82,*) 'ps',ps -c$$$ write(83,*) 'q',q -c$$$ WRITE(85,*) 'q1 = ',q(:,:,1) -c$$$ WRITE(86,*) 'q3 = ',q(:,:,3) - - abort_message = 'Simulation finished' - - call abort_gcm(modname,abort_message,0) - ENDIF -c----------------------------------------------------------------------- -c ecriture du fichier histoire moyenne: -c ------------------------------------- - - IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN - IF(itau.EQ.itaufin) THEN - iav=1 - ELSE - iav=0 - ENDIF -#ifdef CPP_IOIPSL - CALL writedynav(histaveid, nqmx, itau,vcov , - , ucov,teta,pk,phi,q,masse,ps,phis) - call bilan_dyn (2,dtvr*iperiod,dtvr*day_step*periodav, - , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) -#endif - - ENDIF - -c----------------------------------------------------------------------- -c ecriture de la bande histoire: -c ------------------------------ - - IF( MOD(itau,iecri ).EQ.0) THEN -c IF( MOD(itau,iecri*day_step).EQ.0) THEN - - nbetat = nbetatdem - CALL geopot ( ip1jmp1, teta , pk , pks, phis , phi ) - unat=0. - do l=1,llm - unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm) - vnat(:,l)=vcov(:,l)/cv(:) - enddo -#ifdef CPP_IOIPSL -c CALL writehist(histid,histvid, nqmx,itau,vcov, -c s ucov,teta,phi,q,masse,ps,phis) -#else -#include "write_grads_dyn.h" -#endif - - - ENDIF - - IF(itau.EQ.itaufin) THEN - - -#ifdef CPP_IOIPSL - CALL dynredem1("restart.nc",0.0, - , vcov,ucov,teta,q,nqmx,masse,ps) -#endif - - CLOSE(99) - ENDIF - -c----------------------------------------------------------------------- -c gestion de l'integration temporelle: -c ------------------------------------ - - IF( MOD(itau,iperiod).EQ.0 ) THEN - GO TO 1 - ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN - - IF( forward ) THEN -c fin du pas forward et debut du pas backward - - forward = .FALSE. - leapf = .FALSE. - GO TO 2 - - ELSE -c fin du pas backward et debut du premier pas leapfrog - - leapf = .TRUE. - dt = 2.*dtvr - GO TO 2 - END IF - ELSE - -c ...... pas leapfrog ..... - - leapf = .TRUE. - dt = 2.*dtvr - GO TO 2 - END IF - - ELSE - -c ........................................................ -c .............. schema matsuno ............... -c ........................................................ - IF( forward ) THEN - - itau = itau + 1 - iday = day_ini+itau/day_step - time = FLOAT(itau-(iday-day_ini)*day_step)/day_step+time_0 - - IF(time.GT.1.) THEN - time = time-1. - iday = iday+1 - ENDIF - - forward = .FALSE. - IF( itau. EQ. itaufinp1 ) then - abort_message = 'Simulation finished' - call abort_gcm(modname,abort_message,0) - ENDIF - GO TO 2 - - ELSE - - IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN - IF(itau.EQ.itaufin) THEN - iav=1 - ELSE - iav=0 - ENDIF -#ifdef CPP_IOIPSL - CALL writedynav(histaveid, nqmx, itau,vcov , - , ucov,teta,pk,phi,q,masse,ps,phis) - call bilan_dyn (2,dtvr*iperiod,dtvr*day_step*periodav, - , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) -#endif - - ENDIF - - IF(MOD(itau,iecri ).EQ.0) THEN -c IF(MOD(itau,iecri*day_step).EQ.0) THEN - nbetat = nbetatdem - CALL geopot ( ip1jmp1, teta , pk , pks, phis , phi ) - unat=0. - do l=1,llm - unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm) - vnat(:,l)=vcov(:,l)/cv(:) - enddo -#ifdef CPP_IOIPSL -c CALL writehist( histid, histvid, nqmx, itau,vcov , -c , ucov,teta,phi,q,masse,ps,phis) -#else -#include "write_grads_dyn.h" -#endif - - - ENDIF - -#ifdef CPP_IOIPSL - IF(itau.EQ.itaufin) - . CALL dynredem1("restart.nc",0.0, - . vcov,ucov,teta,q,nqmx,masse,ps) -#endif - - forward = .TRUE. - GO TO 1 - - ENDIF - - END IF - - STOP - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/limit_netcdf.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/limit_netcdf.F (revision 706) +++ (revision ) @@ -1,1279 +1,0 @@ -! -! $Header$ -! -C -C - SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque, pctsrf) -c - IMPLICIT none -c -c------------------------------------------------------------- -C Author : L. Fairhead -C Date : 27/01/94 -C Objet : Construction des fichiers de conditions aux limites -C pour le nouveau -C modele a partir de fichiers de climatologie. Les deux -C grilles doivent etre regulieres -c -c Modifie par z.x.li (le23mars1994) -c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999 -c pour lecture netcdf dans LMDZ.3.3 -c Modifie par P;Le Van , juillet 2001 -c------------------------------------------------------------- -c -#include "dimensions.h" -#include "paramet.h" -#include "control.h" -#include "logic.h" -#include "netcdf.inc" -#include "comvert.h" -#include "comgeom2.h" -#include "comconst.h" -#include "dimphy.h" -#include "indicesol.h" -c -c----------------------------------------------------------------------- - LOGICAL interbar, extrap, oldice - - REAL phy_nat(klon,360), phy_nat0(klon) - REAL phy_alb(klon,360) - REAL phy_sst(klon,360) - REAL phy_bil(klon,360) - REAL phy_rug(klon,360) - REAL phy_ice(klon) -c - real pctsrf_t(klon,nbsrf,360) - real pctsrf(klon,nbsrf) - REAL verif - - REAL masque(iip1,jjp1) - REAL mask(iim,jjp1) -CPB -C newlmt indique l'utilisation de la sous-maille fractionnelle -C tandis que l'ancien codage utilise l'indicateur du sol (0,1,2,3) - LOGICAL newlmt, fracterre - PARAMETER(newlmt=.TRUE.) - PARAMETER(fracterre = .TRUE.) - -C Declarations pour le champ de depart - INTEGER imdep, jmdep,lmdep - INTEGER tbid - PARAMETER ( tbid = 60 ) ! >52 semaines - REAL timecoord(tbid) -c - REAL , ALLOCATABLE :: dlon_msk(:), dlat_msk(:) - REAL , ALLOCATABLE :: lonmsk_ini(:), latmsk_ini(:) - REAL , ALLOCATABLE :: dlon(:), dlat(:) - REAL , ALLOCATABLE :: dlon_ini(:), dlat_ini(:) - REAL , ALLOCATABLE :: champ_msk(:), champ(:) - REAL , ALLOCATABLE :: work(:,:) - - CHARACTER*25 title - -C Declarations pour le champ interpole 2D - REAL champint(iim,jjp1) - real chmin,chmax - -C Declarations pour le champ interpole 3D - REAL champtime(iim,jjp1,tbid) - REAL timeyear(tbid) - REAL champan(iip1,jjp1,366) - -C Declarations pour l'inteprolation verticale - REAL ax(tbid), ay(tbid) - REAL by - REAL yder(tbid) - - - INTEGER ierr - INTEGER dimfirst(3) - INTEGER dimlast(3) -c - INTEGER nid, ndim, ntim - INTEGER dims(2), debut(2), epais(2) - INTEGER id_tim - INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB -CPB - INTEGER id_FOCE, id_FSIC, id_FTER, id_FLIC - - INTEGER i, j, k, l, ji -c declarations pour lecture glace de mer - INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret - INTEGER :: itaul(1), fid - REAL :: lev(1), date, dt - REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic - REAL, ALLOCATABLE, DIMENSION(:) :: dlon_lic, dlat_lic - REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic - REAL :: flic_tmp(iip1, jjp1) - -c Diverses variables locales - REAL time -! pour la lecture du fichier masque ocean - integer :: nid_o2a - logical :: couple = .false. - INTEGER :: iml_omask, jml_omask - REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask - REAL, ALLOCATABLE, DIMENSION(:) :: dlon_omask, dlat_omask - REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp - real, dimension(klon) :: ocemask_fi - - INTEGER longcles - PARAMETER ( longcles = 20 ) - REAL clesphy0 ( longcles ) -#include "serre.h" - INTEGER ncid,varid,ndimid(4),dimid - character*30 namedim - CHARACTER*80 :: varname - -cIM28/02/2002 <== PM - REAL tmidmonth(12) - SAVE tmidmonth - DATA tmidmonth/15,45,75,105,135,165,195,225,255,285,315,345/ - -c initialisations: - CALL conf_gcm( 99, .TRUE. , clesphy0 ) - - - pi = 4. * ATAN(1.) - rad = 6 371 229. - omeg = 4.* ASIN(1.)/(24.*3600.) - g = 9.8 - daysec = 86400. - kappa = 0.2857143 - cpp = 1004.70885 - dtvr = daysec/FLOAT(day_step) - CALL inigeom -c -C Traitement du relief au sol -c - write(*,*) 'Traitement du relief au sol pour fabriquer masque' - ierr = NF_OPEN('Relief.nc', NF_NOWRITE, ncid) - - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ierr = NF_INQ_VARID(ncid,'RELIEF',varid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, 'dimension ', imdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ALLOCATE( lonmsk_ini(imdep) ) - ALLOCATE( dlon_msk(imdep) ) - -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,lonmsk_ini) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,lonmsk_ini) -#endif - -c - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, 'dimension ', jmdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ALLOCATE( latmsk_ini(jmdep) ) - ALLOCATE( dlat_msk(jmdep) ) - ALLOCATE( champ_msk(imdep*jmdep) ) - -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,latmsk_ini) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,latmsk_ini) -#endif -c - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,varid,champ_msk) -#else - ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk) -#endif -c - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF -c - title='RELIEF' - - CALL conf_dat2d(title,imdep, jmdep, lonmsk_ini, latmsk_ini, - . dlon_msk, dlat_msk, champ_msk, interbar ) - - DO i = 1, iim - DO j = 1, jjp1 - mask(i,j) = masque(i,j) - ENDDO - ENDDO - WRITE(*,*) 'MASK:' - WRITE(*,'(96i1)')INT(mask) - ierr = NF_CLOSE(ncid) -c -c -C Traitement de la rugosite -c - PRINT*, 'Traitement de la rugosite' - ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ierr = NF_INQ_VARID(ncid,'RUGOS',varid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, 'dimension ', imdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ALLOCATE( dlon_ini(imdep) ) - ALLOCATE( dlon(imdep) ) - -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, 'dimension ', jmdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ALLOCATE( dlat_ini(jmdep) ) - ALLOCATE( dlat(jmdep) ) - -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, 'dimension ', lmdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF -c - ALLOCATE( champ(imdep*jmdep) ) - - DO 200 l = 1, lmdep - dimfirst(1) = 1 - dimfirst(2) = 1 - dimfirst(3) = l -c - dimlast(1) = imdep - dimlast(2) = jmdep - dimlast(3) = 1 -c - PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) - print*,dimfirst,dimlast -#ifdef NC_DOUBLE - ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) -#else - ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - title = 'Rugosite Amip ' -c - CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, - . dlon, dlat, champ, interbar ) - - IF ( interbar ) THEN - DO j = 1, imdep * jmdep - champ(j) = LOG(champ(j)) - ENDDO - - IF( l.EQ.1 ) THEN - WRITE(6,*) '-------------------------------------------------', - ,'------------------------' - WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', - , ' pour la rugosite $$$ ' - WRITE(6,*) '-------------------------------------------------', - ,'------------------------' - ENDIF - CALL inter_barxy ( imdep,jmdep -1,dlon,dlat,champ , - , iim,jjm,rlonu,rlatv, jjp1,champint ) - DO j=1,jjp1 - DO i=1,iim - champint(i,j)=EXP(champint(i,j)) - ENDDO - ENDDO - - DO j = 1, jjp1 - DO i = 1, iim - IF(NINT(mask(i,j)).NE.1) THEN - champint( i,j ) = 0.001 - ENDIF - ENDDO - ENDDO - ELSE - CALL rugosite(imdep, jmdep, dlon, dlat, champ, - . iim, jjp1, rlonv, rlatu, champint, mask) - ENDIF - DO j = 1,jjp1 - DO i = 1, iim - champtime (i,j,l) = champint(i,j) - ENDDO - ENDDO -200 CONTINUE -c - DO l = 1, lmdep - timeyear(l) = timecoord(l) - ENDDO - - PRINT 222, timeyear -222 FORMAT(2x,' Time year ',10f6.1) -c - - PRINT*, 'Interpolation temporelle dans l annee' - - DO j = 1, jjp1 - DO i = 1, iim - DO l = 1, lmdep - ax(l) = timeyear(l) - ay(l) = champtime (i,j,l) - ENDDO - CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) - DO k = 1, 360 - time = FLOAT(k-1) - CALL SPLINT(ax,ay,yder,lmdep,time,by) - champan(i,j,k) = by - ENDDO - ENDDO - ENDDO - DO k = 1, 360 - DO j = 1, jjp1 - champan(iip1,j,k) = champan(1,j,k) - ENDDO - IF ( k.EQ.10 ) THEN - DO j = 1, jjp1 - CALL minmax( iip1,champan(1,j,10),chmin,chmax ) - PRINT *,' Rugosite au temps 10 ', chmin,chmax,j - ENDDO - ENDIF - ENDDO -c - DO k = 1, 360 - CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k)) - ENDDO -c - ierr = NF_CLOSE(ncid) - - DEALLOCATE( dlon ) - DEALLOCATE( dlon_ini ) - DEALLOCATE( dlat ) - DEALLOCATE( dlat_ini ) - DEALLOCATE( champ ) -c -c -C Traitement de la glace oceanique -c - PRINT*, 'Traitement de la glace oceanique' - - ierr = NF_OPEN('amipbc_sic_1x1.nc', NF_NOWRITE, ncid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - -cIM22/02/2002 -cIM07/03/2002 AMIP.nc & amip79to95.nc -cIM ierr = NF_INQ_VARID(ncid,'SEA_ICE',varid) -cIM07/03/2002 amipbc_sic_1x1_clim.nc & amipbc_sic_1x1.nc - ierr = NF_INQ_VARID(ncid,'sicbcs',varid) -cIM22/02/2002 - if (ierr.ne.0) then - print *, NF_STRERROR(ierr),'sicbcs' - STOP - ENDIF - ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, 'dimension ', imdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ALLOCATE ( dlon_ini(imdep) ) - ALLOCATE ( dlon(imdep) ) - -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, jmdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ALLOCATE ( dlat_ini(jmdep) ) - ALLOCATE ( dlat(jmdep) ) - -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, lmdep -cIM28/02/2002 -cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours -c Ici on suppose qu'on a 12 mois (de 30 jours). - IF (lmdep.NE.12) THEN - print *, 'Unknown AMIP file: not 12 months ?' - STOP - ENDIF -cIM28/02/2002 - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF -c - ALLOCATE ( champ(imdep*jmdep) ) - - DO l = 1, lmdep - dimfirst(1) = 1 - dimfirst(2) = 1 - dimfirst(3) = l -c - dimlast(1) = imdep - dimlast(2) = jmdep - dimlast(3) = 1 -c - PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) -#ifdef NC_DOUBLE - ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) -#else - ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - title = 'Sea-ice Amip ' -c - CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, - . dlon, dlat, champ, interbar ) -c - IF( oldice ) THEN - CALL sea_ice(imdep, jmdep, dlon, dlat, champ, - . iim, jjp1, rlonv, rlatu, champint ) - ELSEIF ( interbar ) THEN - IF( l.EQ.1 ) THEN - WRITE(6,*) '-------------------------------------------------', - ,'------------------------' - WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', - , ' pour Sea-ice Amip $$$ ' - WRITE(6,*) '-------------------------------------------------', - ,'------------------------' - ENDIF -cIM07/03/2002 -cIM22/02/2002 : Sea-ice Amip entre 0. et 1. -cIM PRINT*,'SUB. limit_netcdf.F IM : Sea-ice et SST Amip_new clim' -cIM DO j = 1, imdep * jmdep -cIM28/02/2002 <==PM champ(j) = champ(j)/100. -cIM14/03/2002 champ(j) = max(0.0,(min(1.0, (champ(j)/100.) ))) -cIM champ(j) = amax1(0.0,(amin1(1.0, (champ(j)/100.) ))) -cIM ENDDO -cIM22/02/2002 - CALL inter_barxy ( imdep,jmdep -1,dlon, dlat , - , champ, iim, jjm, rlonu, rlatv, jjp1, champint ) - ELSE - CALL sea_ice(imdep, jmdep, dlon, dlat, champ, - . iim, jjp1, rlonv, rlatu, champint ) - ENDIF - DO j = 1,jjp1 - DO i = 1, iim - champtime (i,j,l) = champint(i,j) - ENDDO - ENDDO - ENDDO -c - DO l = 1, lmdep -cIM28/02/2002 <== PM timeyear(l) = timecoord(l) -cIM timeyear(l) = timecoord(l) -cIM07/03/2002 - timeyear(l) = tmidmonth(l) - ENDDO - PRINT 222, timeyear -c - PRINT*, 'Interpolation temporelle' - DO j = 1, jjp1 - DO i = 1, iim - DO l = 1, lmdep - ax(l) = timeyear(l) - ay(l) = champtime (i,j,l) - ENDDO - CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) - DO k = 1, 360 - time = FLOAT(k-1) - CALL SPLINT(ax,ay,yder,lmdep,time,by) - champan(i,j,k) = by - ENDDO - ENDDO - ENDDO - DO k = 1, 360 - DO j = 1, jjp1 - champan(iip1, j, k) = champan(1, j, k) - ENDDO - IF ( k.EQ.10 ) THEN - DO j = 1, jjp1 - CALL minmax( iip1,champan(1,j,10),chmin,chmax ) - PRINT *,' Sea ice au temps 10 ', chmin,chmax,j - ENDDO - ENDIF - ENDDO -c -cIM14/03/2002 : Sea-ice Amip entre 0. et 1. - PRINT*,'SUB. limit_netcdf.F IM : Sea-ice Amipbc ' - DO k = 1, 360 - DO j = 1, jjp1 - DO i = 1, iim - champan(i, j, k) = - $ amax1(0.0,(amin1(1.0,(champan(i, j, k)/100.)))) - ENDDO - champan(iip1, j, k) = champan(1, j, k) - ENDDO - ENDDO -cIM14/03/2002 - - DO k = 1, 360 - CALL gr_dyn_fi(1, iip1, jjp1, klon, - . champan(1,1,k), phy_ice) - IF ( newlmt) THEN - -CPB en attendant de mettre fraction de terre -c - WHERE(phy_ice(1:klon) .GE. 1.) phy_ice(1 : klon) = 1. - WHERE(phy_ice(1:klon) .LT. EPSFRA) phy_ice(1 : klon) = 0. -c - IF (fracterre ) THEN -c WRITE(*,*) 'passe dans cas fracterre' - pctsrf_t(:,is_ter,k) = pctsrf(:,is_ter) - pctsrf_t(:,is_lic,k) = pctsrf(:,is_lic) - pctsrf_t(1:klon,is_sic,k) = phy_ice(1:klon) - $ - pctsrf_t(1:klon,is_lic,k) -c Il y a des cas ou il y a de la glace dans landiceref et pas dans AMIP - WHERE (pctsrf_t(1:klon,is_sic,k) .LE. 0) - pctsrf_t(1:klon,is_sic,k) = 0. - END WHERE - WHERE( 1. - zmasq(1:klon) .LT. EPSFRA) - pctsrf_t(1:klon,is_sic,k) = 0. - pctsrf_t(1:klon,is_oce,k) = 0. - END WHERE - DO i = 1, klon - IF ( 1. - zmasq(i) .GT. EPSFRA) THEN - IF ( pctsrf_t(i,is_sic,k) .GE. 1 - zmasq(i)) THEN - pctsrf_t(i,is_sic,k) = 1 - zmasq(i) - pctsrf_t(i,is_oce,k) = 0. - ELSE - pctsrf_t(i,is_oce,k) = 1 - zmasq(i) - $ - pctsrf_t(i,is_sic,k) - IF (pctsrf_t(i,is_oce,k) .LT. EPSFRA) THEN - pctsrf_t(i,is_oce,k) = 0. - pctsrf_t(i,is_sic,k) = 1 - zmasq(i) - ENDIF - ENDIF - ENDIF - if (pctsrf_t(i,is_oce,k) .lt. 0.) then - WRITE(*,*) 'pb sous maille au point : i,k ' - $ , i,k,pctsrf_t(:,is_oce,k) - ENDIF - IF ( abs( pctsrf_t(i, is_ter,k) + pctsrf_t(i, is_lic,k) + - $ pctsrf_t(i, is_oce,k) + pctsrf_t(i, is_sic,k) - 1.) - $ .GT. EPSFRA) THEN - WRITE(*,*) 'physiq : pb sous surface au point ', i, - $ pctsrf_t(i, 1 : nbsrf,k), phy_ice(i) - ENDIF - END DO - ELSE - DO i = 1, klon - pctsrf_t(i,is_ter,k) = pctsrf(i,is_ter) - IF (NINT(pctsrf(i,is_ter)).EQ.1 ) THEN - pctsrf_t(i,is_sic,k) = 0. - pctsrf_t(i,is_oce,k) = 0. - IF(phy_ice(i) .GE. 1.e-5) THEN - pctsrf_t(i,is_lic,k) = phy_ice(i) - pctsrf_t(i,is_ter,k) = pctsrf_t(i,is_ter,k) - . - pctsrf_t(i,is_lic,k) - ELSE - pctsrf_t(i,is_lic,k) = 0. - ENDIF - ELSE - pctsrf_t(i,is_lic,k) = 0. - IF(phy_ice(i) .GE. 1.e-5) THEN - pctsrf_t(i,is_ter,k) = 0. - pctsrf_t(i,is_sic,k) = phy_ice(i) - pctsrf_t(i,is_oce,k) = 1. - pctsrf_t(i,is_sic,k) - ELSE - pctsrf_t(i,is_sic,k) = 0. - pctsrf_t(i,is_oce,k) = 1. - ENDIF - ENDIF - verif = pctsrf_t(i,is_ter,k) + - . pctsrf_t(i,is_oce,k) + - . pctsrf_t(i,is_sic,k) + - . pctsrf_t(i,is_lic,k) - IF ( verif .LT. 1. - 1.e-5 .OR. - $ verif .GT. 1 + 1.e-5) THEN - WRITE(*,*) 'pb sous maille au point : i,k,verif ' - $ , i,k,verif - ENDIF - END DO - ENDIF - ELSE - DO i = 1, klon - phy_nat(i,k) = phy_nat0(i) - IF ( (phy_ice(i) - 0.5).GE.1.e-5 ) THEN - IF (NINT(phy_nat0(i)).EQ.0) THEN - phy_nat(i,k) = 3.0 - ELSE - phy_nat(i,k) = 2.0 - ENDIF - ENDIF - IF( NINT(phy_nat(i,k)).EQ.0 ) THEN - IF ( phy_rug(i,k).NE.0.001 ) phy_rug(i,k) = 0.001 - ENDIF - END DO - ENDIF - ENDDO -c - - ierr = NF_CLOSE(ncid) -c - DEALLOCATE( dlon ) - DEALLOCATE( dlon_ini ) - DEALLOCATE( dlat ) - DEALLOCATE( dlat_ini ) - DEALLOCATE( champ ) - -477 continue -c -C Traitement de la sst -c - PRINT*, 'Traitement de la sst' -c ierr = NF_OPEN('AMIP_SST.nc', NF_NOWRITE, ncid) - ierr = NF_OPEN('amipbc_sst_1x1.nc', NF_NOWRITE, ncid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - -cIM22/02/2002 -cIM ierr = NF_INQ_VARID(ncid,'SST',varid) - ierr = NF_INQ_VARID(ncid,'tosbcs',varid) -cIM22/02/2002 - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable SST ', namedim,'dimension ', imdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ALLOCATE( dlon_ini(imdep) ) - ALLOCATE( dlon(imdep) ) - -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) -#endif - - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable SST ', namedim, 'dimension ', jmdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ALLOCATE( dlat_ini(jmdep) ) - ALLOCATE( dlat(jmdep) ) - -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, 'dimension ', lmdep -cIM28/02/2002 -cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours -c Ici on suppose qu'on a 12 mois (de 30 jours). - IF (lmdep.NE.12) THEN - print *, 'Unknown AMIP file: not 12 months ?' - STOP - ENDIF -cIM28/02/2002 - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ALLOCATE( champ(imdep*jmdep) ) - IF( extrap ) THEN - ALLOCATE ( work(imdep,jmdep) ) - ENDIF -c - DO l = 1, lmdep - dimfirst(1) = 1 - dimfirst(2) = 1 - dimfirst(3) = l -c - dimlast(1) = imdep - dimlast(2) = jmdep - dimlast(3) = 1 -c - PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) -#ifdef NC_DOUBLE - ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) -#else - ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - title='Sst Amip' -c - CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, - . dlon, dlat, champ, interbar ) - IF ( extrap ) THEN - CALL extrapol(champ, imdep, jmdep, 999999.,.TRUE.,.TRUE.,2,work) - ENDIF -c - - IF ( interbar ) THEN - IF( l.EQ.1 ) THEN - WRITE(6,*) '-------------------------------------------------', - ,'------------------------' - WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', - , ' pour la Sst Amip $$$ ' - WRITE(6,*) '-------------------------------------------------', - ,'------------------------' - ENDIF - CALL inter_barxy ( imdep,jmdep -1,dlon, dlat , - , champ, iim, jjm, rlonu, rlatv, jjp1, champint ) - ELSE - CALL grille_m(imdep, jmdep, dlon, dlat, champ, - . iim, jjp1, rlonv, rlatu, champint ) - ENDIF - - DO j = 1,jjp1 - DO i = 1, iim - champtime (i,j,l) = champint(i,j) - ENDDO - ENDDO - ENDDO -c - DO l = 1, lmdep -cIM28/02/2002 <==PM timeyear(l) = timecoord(l) - timeyear(l) = tmidmonth(l) - ENDDO - print 222, timeyear -c -C interpolation temporelle - DO j = 1, jjp1 - DO i = 1, iim - DO l = 1, lmdep - ax(l) = timeyear(l) - ay(l) = champtime (i,j,l) - ENDDO - CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) - DO k = 1, 360 - time = FLOAT(k-1) - CALL SPLINT(ax,ay,yder,lmdep,time,by) - champan(i,j,k) = by - ENDDO - ENDDO - ENDDO - DO k = 1, 360 - DO j = 1, jjp1 - champan(iip1,j,k) = champan(1,j,k) - ENDDO - IF ( k.EQ.10 ) THEN - DO j = 1, jjp1 - CALL minmax( iip1,champan(1,j,10),chmin,chmax ) - PRINT *,' SST au temps 10 ', chmin,chmax,j - ENDDO - ENDIF - ENDDO -c -cIM14/03/2002 : SST amipbc greater then 271.38 - PRINT*,'SUB. limit_netcdf.F IM : SST Amipbc >= 271.38 ' - DO k = 1, 360 - DO j = 1, jjp1 - DO i = 1, iim - champan(i, j, k) = amax1(champan(i, j, k), 271.38) - ENDDO - champan(iip1, j, k) = champan(1, j, k) - ENDDO - ENDDO -cIM14/03/2002 - DO k = 1, 360 - CALL gr_dyn_fi(1, iip1, jjp1, klon, - . champan(1,1,k), phy_sst(1,k)) - ENDDO -c - ierr = NF_CLOSE(ncid) -c - DEALLOCATE( dlon ) - DEALLOCATE( dlon_ini ) - DEALLOCATE( dlat ) - DEALLOCATE( dlat_ini ) - DEALLOCATE( champ ) -c -C Traitement de l'albedo -c - PRINT*, 'Traitement de l albedo' - ierr = NF_OPEN('Albedo.nc', NF_NOWRITE, ncid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_VARID(ncid,'ALBEDO',varid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, 'dimension ', imdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ALLOCATE ( dlon_ini(imdep) ) - ALLOCATE ( dlon(imdep) ) - -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, 'dimension ', jmdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - ALLOCATE ( dlat_ini(jmdep) ) - ALLOCATE ( dlat(jmdep) ) - -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - print*,'variable ', namedim, 'dimension ', lmdep - ierr = NF_INQ_VARID(ncid,namedim,dimid) - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF -#ifdef NC_DOUBLE - ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) -#else - ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF -c - ALLOCATE ( champ(imdep*jmdep) ) - - DO l = 1, lmdep - dimfirst(1) = 1 - dimfirst(2) = 1 - dimfirst(3) = l -c - dimlast(1) = imdep - dimlast(2) = jmdep - dimlast(3) = 1 -c - PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) -#ifdef NC_DOUBLE - ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) -#else - ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) -#endif - if (ierr.ne.0) then - print *, NF_STRERROR(ierr) - STOP - ENDIF - - title='Albedo Amip' -c - CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, - . dlon, dlat, champ, interbar ) -c -c - IF ( interbar ) THEN - IF( l.EQ.1 ) THEN - WRITE(6,*) '-------------------------------------------------', - ,'------------------------' - WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', - , ' pour l Albedo Amip $$$ ' - WRITE(6,*) '-------------------------------------------------', - ,'------------------------' - ENDIF - - CALL inter_barxy ( imdep,jmdep -1,dlon, dlat , - , champ, iim, jjm, rlonu, rlatv, jjp1, champint ) - ELSE - CALL grille_m(imdep, jmdep, dlon, dlat, champ, - . iim, jjp1, rlonv, rlatu, champint ) - ENDIF -c - DO j = 1,jjp1 - DO i = 1, iim - champtime (i, j, l) = champint(i, j) - ENDDO - ENDDO - ENDDO -c - DO l = 1, lmdep - timeyear(l) = timecoord(l) - ENDDO - print 222, timeyear -c -C interpolation temporelle - DO j = 1, jjp1 - DO i = 1, iim - DO l = 1, lmdep - ax(l) = timeyear(l) - ay(l) = champtime (i, j, l) - ENDDO - CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) - DO k = 1, 360 - time = FLOAT(k-1) - CALL SPLINT(ax,ay,yder,lmdep,time,by) - champan(i,j,k) = by - ENDDO - ENDDO - ENDDO - DO k = 1, 360 - DO j = 1, jjp1 - champan(iip1, j, k) = champan(1, j, k) - ENDDO - IF ( k.EQ.10 ) THEN - DO j = 1, jjp1 - CALL minmax( iip1,champan(1,j,10),chmin,chmax ) - PRINT *,' Albedo au temps 10 ', chmin,chmax,j - ENDDO - ENDIF - ENDDO -c - DO k = 1, 360 - CALL gr_dyn_fi(1, iip1, jjp1, klon, - . champan(1,1,k), phy_alb(1,k)) - ENDDO -c - ierr = NF_CLOSE(ncid) -c -c - DO k = 1, 360 - DO i = 1, klon - phy_bil(i,k) = 0.0 - ENDDO - ENDDO -c - PRINT*, 'Ecriture du fichier limit' -c - ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid) -c - ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30, - . "Fichier conditions aux limites") - ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim) - ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim) -c - dims(1) = ndim - dims(2) = ntim -c - ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim) - ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17, - . "Jour dans l annee") - IF (newlmt) THEN -c - ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE) - ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 14, - . "Fraction ocean") -c - ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC) - ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 21, - . "Fraction glace de mer") -c - ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER) - ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 14, - . "Fraction terre") -c - ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC) - ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 17, - . "Fraction land ice") -c - ELSE - ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT) - ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23, - . "Nature du sol (0,1,2,3)") - ENDIF - ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST) - ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35, - . "Temperature superficielle de la mer") - ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS) - ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32, - . "Reference flux de chaleur au sol") - ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB) - ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19, - . "Albedo a la surface") - ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG) - ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8, - . "Rugosite") -c - ierr = NF_ENDDEF(nid) -c - DO k = 1, 360 -c - debut(1) = 1 - debut(2) = k - epais(1) = klon - epais(2) = 1 -c -#ifdef NC_DOUBLE - ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k)) -c - IF (newlmt ) THEN - ierr = NF_PUT_VARA_DOUBLE (nid,id_FOCE,debut,epais - $ ,pctsrf_t(1,is_oce,k)) - ierr = NF_PUT_VARA_DOUBLE (nid,id_FSIC,debut,epais - $ ,pctsrf_t(1,is_sic,k)) - ierr = NF_PUT_VARA_DOUBLE (nid,id_FTER,debut,epais - $ ,pctsrf_t(1,is_ter,k)) - ierr = NF_PUT_VARA_DOUBLE (nid,id_FLIC,debut,epais - $ ,pctsrf_t(1,is_lic,k)) - ELSE - ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais - $ ,phy_nat(1,k)) - ENDIF -c - ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k)) - ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k)) - ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k)) - ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k)) -#else - ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k)) - IF (newlmt ) THEN - ierr = NF_PUT_VARA_REAL (nid,id_FOCE,debut,epais - $ ,pctsrf_t(1,is_oce,k)) - ierr = NF_PUT_VARA_REAL (nid,id_FSIC,debut,epais - $ ,pctsrf_t(1,is_sic,k)) - ierr = NF_PUT_VARA_REAL (nid,id_FTER,debut,epais - $ ,pctsrf_t(1,is_ter,k)) - ierr = NF_PUT_VARA_REAL (nid,id_FLIC,debut,epais - $ ,pctsrf_t(1,is_lic,k)) - ELSE - ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais - $ ,phy_nat(1,k)) - ENDIF - ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k)) - ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k)) - ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k)) - ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k)) -#endif -c - ENDDO -c - ierr = NF_CLOSE(nid) -c - STOP - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/massbar.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/massbar.F (revision 706) +++ (revision ) @@ -1,100 +1,0 @@ -! -! $Header$ -! - SUBROUTINE massbar( masse, massebx, masseby ) -c -c ********************************************************************** -c -c Calcule les moyennes en x et y de la masse d'air dans chaque maille. -c ********************************************************************** -c Auteurs : P. Le Van , Fr. Hourdin . -c .......... -c -c .. masse est un argum. d'entree pour le s-pg ... -c .. massebx,masseby sont des argum. de sortie pour le s-pg ... -c -c -c IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comgeom.h" -c - REAL masse( ip1jmp1,llm ), massebx( ip1jmp1,llm ) , - * masseby( ip1jm,llm ) -c -c -c Methode pour calculer massebx et masseby . -c ---------------------------------------- -c -c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires -c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) -c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) -c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) -c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) -c -c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) -c -c N.B . Pour plus de details, voir s-pg ... iniconst ... -c -c -c -c alpha4 . . alpha1 . alpha4 -c (i,j) (i,j) (i+1,j) -c -c P . U . . P -c (i,j) (i,j) (i+1,j) -c -c alpha3 . . alpha2 .alpha3 -c (i,j) (i,j) (i+1,j) -c -c V . Z . . V -c (i,j) -c -c alpha4 . . alpha1 .alpha4 -c (i,j+1) (i,j+1) (i+1,j+1) -c -c P . U . . P -c (i,j+1) (i+1,j+1) -c -c -c -c On a : -c -c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + -c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) -c localise au point ... U (i,j) ... -c -c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + -c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) -c localise au point ... V (i,j) ... -c -c -c======================================================================= - - DO 100 l = 1 , llm -c - DO ij = 1, ip1jmp1 - 1 - massebx(ij,l) = masse( ij, l) * alpha1p2( ij ) + - * masse(ij+1, l) * alpha3p4(ij+1 ) - ENDDO - -c .... correction pour massebx( iip1,j) ..... -c ... massebx(iip1,j)= massebx(1,j) ... -c -CDIR$ IVDEP - DO ij = iip1, ip1jmp1, iip1 - massebx( ij,l ) = massebx( ij - iim,l ) - ENDDO - - - DO ij = 1,ip1jm - masseby( ij,l ) = masse( ij , l ) * alpha2p3( ij ) + - * masse(ij+iip1, l ) * alpha1p4( ij+iip1 ) - ENDDO - -100 CONTINUE -c - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/misc_mod.F90 =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/misc_mod.F90 (revision 706) +++ (revision ) @@ -1,6 +1,0 @@ -module misc_mod - integer,save :: itaumax - logical,save :: adjust - integer,save :: ItCount - logical,save :: debug -end module misc_mod Index: LMDZ4/branches/V3_test/libf/dyn3dpar/qminimum.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/qminimum.F (revision 706) +++ (revision ) @@ -1,85 +1,0 @@ -! -! $Header$ -! - SUBROUTINE qminimum( q,nq,deltap ) - - IMPLICIT none -c -c -- Objet : Traiter les valeurs trop petites (meme negatives) -c pour l'eau vapeur et l'eau liquide -c -#include "dimensions.h" -#include "paramet.h" -#include "comvert.h" -c - INTEGER nq - REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm) -c - INTEGER iq_vap, iq_liq - PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur - PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide - REAL seuil_vap, seuil_liq - PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur - PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide -c -c NB. ....( Il est souhaitable mais non obligatoire que les valeurs des -c parametres seuil_vap, seuil_liq soient pareilles a celles -c qui sont utilisees dans la routine ADDFI ) -c ................................................................. -c - INTEGER i, k, iq - REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe -c - REAL SSUM -c - INTEGER imprim - SAVE imprim - DATA imprim /0/ -c -c Quand l'eau liquide est trop petite (ou negative), on prend -c l'eau vapeur de la meme couche et la convertit en eau liquide -c (sans changer la temperature !) -c - DO 1000 k = 1, llm - DO 1040 i = 1, ip1jmp1 - zx_defau = AMAX1( seuil_liq - q(i,k,iq_liq), 0.0 ) - q(i,k,iq_vap) = q(i,k,iq_vap) - zx_defau - q(i,k,iq_liq) = q(i,k,iq_liq) + zx_defau - 1040 CONTINUE - 1000 CONTINUE -c -c Quand l'eau vapeur est trop faible (ou negative), on complete -c le defaut en prennant de l'eau vapeur de la couche au-dessous. -c - iq = iq_vap -c - DO k = llm, 2, -1 -ccc zx_abc = dpres(k) / dpres(k-1) - DO i = 1, ip1jmp1 - zx_abc = deltap(i,k)/deltap(i,k-1) - zx_defau = AMAX1( seuil_vap - q(i,k,iq), 0.0 ) - q(i,k-1,iq) = q(i,k-1,iq) - zx_defau * zx_abc - q(i,k,iq) = q(i,k,iq) + zx_defau - ENDDO - ENDDO -c -c Quand il s'agit de la premiere couche au-dessus du sol, on -c doit imprimer un message d'avertissement (saturation possible). -c - DO i = 1, ip1jmp1 - zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) ) - q(i,1,iq) = AMAX1( q(i,1,iq), seuil_vap ) - ENDDO - pompe = SSUM(ip1jmp1,zx_pump,1) - IF (imprim.LE.500 .AND. pompe.GT.0.0) THEN - WRITE(6,'(1x,"ATT!:on pompe de l eau au sol",e15.7)') pompe - DO i = 1, ip1jmp1 - IF (zx_pump(i).GT.0.0) THEN - imprim = imprim + 1 - PRINT*,'QMINIMUM: en ',i,zx_pump(i) - ENDIF - ENDDO - ENDIF -c - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/tourpot.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/tourpot.F (revision 706) +++ (revision ) @@ -1,81 +1,0 @@ -! -! $Header$ -! - SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot ) - IMPLICIT NONE - -c======================================================================= -c -c Auteur: P. Le Van -c ------- -c -c Objet: -c ------ -c -c ******************************************************************* -c ......... calcul du tourbillon potentiel ......... -c ******************************************************************* -c -c vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg . -c vorpot est un argum.de sortie pour le s-pg . -c -c======================================================================= - -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" -#include "logic.h" - - REAL rot( ip1jm,llm ) - REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm ) - REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm ) - - INTEGER l, ij - - - - -c ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy .. - - - -c ........ Calcul du rotationnel du vent V puis filtrage ........ - - DO 5 l = 1,llm - - DO 2 ij = 1, ip1jm - 1 - rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l) - 2 CONTINUE - -c .... correction pour rot( iip1,j,l ) ..... -c .... rot(iip1,j,l) = rot(1,j,l) ..... - -CDIR$ IVDEP - - DO 3 ij = iip1, ip1jm, iip1 - rot( ij,l ) = rot( ij -iim, l ) - 3 CONTINUE - - 5 CONTINUE - - - CALL filtreg( rot, jjm, llm, 2, 1, .FALSE., 1 ) - - - DO 10 l = 1, llm - - DO 6 ij = 1, ip1jm - 1 - vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l) - 6 CONTINUE - -c ..... correction pour vorpot( iip1,j,l) ..... -c .... vorpot(iip1,j,l)= vorpot(1,j,l) .... -CDIR$ IVDEP - DO 8 ij = iip1, ip1jm, iip1 - vorpot( ij,l ) = vorpot( ij -iim,l ) - 8 CONTINUE - - 10 CONTINUE - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/vampir.F90 =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/vampir.F90 (revision 706) +++ (revision ) @@ -1,53 +1,0 @@ -module Vampir - - INTEGER,parameter :: VTcaldyn=1 - INTEGER,parameter :: VTintegre=2 - INTEGER,parameter :: VTadvection=3 - INTEGER,parameter :: VTdissipation=4 - INTEGER,parameter :: VThallo=5 - INTEGER,parameter :: VTphysiq=6 - INTEGER,parameter :: VTinca=7 - -contains - - subroutine InitVampir - implicit none -#ifdef USE_VT - include 'VT.inc' - integer :: ierr - - call VTSYMDEF(VTcaldyn,"caldyn","caldyn",ierr) - call VTSYMDEF(VTintegre,"integre","integre",ierr) - call VTSYMDEF(VTadvection,"advection","advection",ierr) - call VTSYMDEF(VTdissipation,"dissipation","dissipation",ierr) - call VTSYMDEF(VThallo,"hallo","hallo",ierr) - call VTSYMDEF(VTphysiq,"physiq","physiq",ierr) - call VTSYMDEF(VTinca,"inca","inca",ierr) -#endif - end subroutine InitVampir - - subroutine VTb(number) - implicit none - INTEGER :: number -#ifdef USE_VT - include 'VT.inc' - integer :: ierr - - call VTBEGIN(number,ierr) -#endif - end subroutine VTb - - subroutine VTe(number) - implicit none - INTEGER :: Number -#ifdef USE_VT - include 'VT.inc' - integer :: ierr - - call VTEND(number,ierr) -#endif - - end subroutine VTe - -end module Vampir - Index: LMDZ4/branches/V3_test/libf/dyn3dpar/vitvert.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/vitvert.F (revision 706) +++ (revision ) @@ -1,52 +1,0 @@ -! -! $Header$ -! - SUBROUTINE vitvert ( convm , w ) -c - IMPLICIT NONE - -c======================================================================= -c -c Auteurs: P. Le Van , F. Hourdin . -c ------- -c -c Objet: -c ------ -c -c ******************************************************************* -c .... calcul de la vitesse verticale aux niveaux sigma .... -c ******************************************************************* -c convm est un argument d'entree pour le s-pg ...... -c w est un argument de sortie pour le s-pg ...... -c -c la vitesse verticale est orientee de haut en bas . -c au sol, au niveau sigma(1), w(i,j,1) = 0. -c au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi -c egale a 0. et n'est pas stockee dans le tableau w . -c -c -c======================================================================= - -#include "dimensions.h" -#include "paramet.h" -#include "comvert.h" - - REAL w(ip1jmp1,llm),convm(ip1jmp1,llm) - INTEGER l, ij - - - - DO 2 l = 1,llmm1 - - DO 1 ij = 1,ip1jmp1 - w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 ) - 1 CONTINUE - - 2 CONTINUE - - DO 5 ij = 1,ip1jmp1 - w(ij,1) = 0. -5 CONTINUE - - RETURN - END Index: LMDZ4/branches/V3_test/libf/dyn3dpar/vlsplt.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/vlsplt.F (revision 706) +++ (revision ) @@ -1,961 +1,0 @@ -! -! $Header$ -! -c -c - - SUBROUTINE vlsplt(q,pente_max,masse,w,pbaru,pbarv,pdt) -c -c Auteurs: P.Le Van, F.Hourdin, F.Forget -c -c ******************************************************************** -c Shema d'advection " pseudo amont " . -c ******************************************************************** -c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... -c -c pente_max facteur de limitation des pentes: 2 en general -c 0 pour un schema amont -c pbaru,pbarv,w flux de masse en u ,v ,w -c pdt pas de temps -c -c -------------------------------------------------------------------- - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "logic.h" -#include "comvert.h" -#include "comconst.h" - -c -c Arguments: -c ---------- - REAL masse(ip1jmp1,llm),pente_max -c REAL masse(iip1,jjp1,llm),pente_max - REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) - REAL q(ip1jmp1,llm) -c REAL q(iip1,jjp1,llm) - REAL w(ip1jmp1,llm),pdt -c -c Local -c --------- -c - INTEGER i,ij,l,j,ii - INTEGER ijlqmin,iqmin,jqmin,lqmin -c - REAL zm(ip1jmp1,llm),newmasse - REAL mu(ip1jmp1,llm) - REAL mv(ip1jm,llm) - REAL mw(ip1jmp1,llm+1) - REAL zq(ip1jmp1,llm),zz - REAL dqx(ip1jmp1,llm),dqy(ip1jmp1,llm),dqz(ip1jmp1,llm) - REAL second,temps0,temps1,temps2,temps3 - REAL ztemps1,ztemps2,ztemps3 - REAL zzpbar, zzw - LOGICAL testcpu - SAVE testcpu - SAVE temps1,temps2,temps3 - INTEGER iminn,imaxx - - REAL qmin,qmax - DATA qmin,qmax/0.,1.e33/ - DATA testcpu/.false./ - DATA temps1,temps2,temps3/0.,0.,0./ - - - zzpbar = 0.5 * pdt - zzw = pdt - DO l=1,llm - DO ij = iip2,ip1jm - mu(ij,l)=pbaru(ij,l) * zzpbar - ENDDO - DO ij=1,ip1jm - mv(ij,l)=pbarv(ij,l) * zzpbar - ENDDO - DO ij=1,ip1jmp1 - mw(ij,l)=w(ij,l) * zzw - ENDDO - ENDDO - - DO ij=1,ip1jmp1 - mw(ij,llm+1)=0. - ENDDO - - CALL SCOPY(ijp1llm,q,1,zq,1) - CALL SCOPY(ijp1llm,masse,1,zm,1) - -cprint*,'Entree vlx1' -c call minmaxq(zq,qmin,qmax,'avant vlx ') - call vlx(zq,pente_max,zm,mu) -cprint*,'Sortie vlx1' -c call minmaxq(zq,qmin,qmax,'apres vlx1 ') - -c print*,'Entree vly1' - call vly(zq,pente_max,zm,mv) -c call minmaxq(zq,qmin,qmax,'apres vly1 ') -cprint*,'Sortie vly1' - call vlz(zq,pente_max,zm,mw) -c call minmaxq(zq,qmin,qmax,'apres vlz ') - - - call vly(zq,pente_max,zm,mv) -c call minmaxq(zq,qmin,qmax,'apres vly ') - - - call vlx(zq,pente_max,zm,mu) -c call minmaxq(zq,qmin,qmax,'apres vlx2 ') - - - DO l=1,llm - DO ij=1,ip1jmp1 - q(ij,l)=zq(ij,l) - ENDDO - DO ij=1,ip1jm+1,iip1 - q(ij+iim,l)=q(ij,l) - ENDDO - ENDDO - - RETURN - END - SUBROUTINE vlx(q,pente_max,masse,u_m) - -c Auteurs: P.Le Van, F.Hourdin, F.Forget -c -c ******************************************************************** -c Shema d'advection " pseudo amont " . -c ******************************************************************** -c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... -c -c -c -------------------------------------------------------------------- - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "logic.h" -#include "comvert.h" -#include "comconst.h" -c -c -c Arguments: -c ---------- - REAL masse(ip1jmp1,llm),pente_max - REAL u_m( ip1jmp1,llm ),pbarv( iip1,jjm,llm) - REAL q(ip1jmp1,llm) - REAL w(ip1jmp1,llm) -c -c Local -c --------- -c - INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju - INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm) -c - REAL new_m,zu_m,zdum(ip1jmp1,llm) - REAL sigu(ip1jmp1),dxq(ip1jmp1,llm),dxqu(ip1jmp1) - REAL zz(ip1jmp1) - REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) - REAL u_mq(ip1jmp1,llm) - - Logical extremum,first,testcpu - SAVE first,testcpu - - REAL SSUM - REAL temps0,temps1,temps2,temps3,temps4,temps5,second - SAVE temps0,temps1,temps2,temps3,temps4,temps5 - - REAL z1,z2,z3 - - DATA first,testcpu/.true.,.false./ - - IF(first) THEN - temps1=0. - temps2=0. - temps3=0. - temps4=0. - temps5=0. - first=.false. - ENDIF - -c calcul de la pente a droite et a gauche de la maille - - - IF (pente_max.gt.-1.e-5) THEN -c IF (pente_max.gt.10) THEN - -c calcul des pentes avec limitation, Van Leer scheme I: -c ----------------------------------------------------- - -c calcul de la pente aux points u - DO l = 1, llm - DO ij=iip2,ip1jm-1 - dxqu(ij)=q(ij+1,l)-q(ij,l) -c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' -c sigu(ij)=u_m(ij,l)/masse(ij,l) - ENDDO - DO ij=iip1+iip1,ip1jm,iip1 - dxqu(ij)=dxqu(ij-iim) -c sigu(ij)=sigu(ij-iim) - ENDDO - - DO ij=iip2,ip1jm - adxqu(ij)=abs(dxqu(ij)) - ENDDO - -c calcul de la pente maximum dans la maille en valeur absolue - - DO ij=iip2+1,ip1jm - dxqmax(ij,l)=pente_max* - , min(adxqu(ij-1),adxqu(ij)) -c limitation subtile -c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) - - - ENDDO - - DO ij=iip1+iip1,ip1jm,iip1 - dxqmax(ij-iim,l)=dxqmax(ij,l) - ENDDO - - DO ij=iip2+1,ip1jm -#ifdef CRAY - dxq(ij,l)= - , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) -#else - IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN - dxq(ij,l)=dxqu(ij-1)+dxqu(ij) - ELSE -c extremum local - dxq(ij,l)=0. - ENDIF -#endif - dxq(ij,l)=0.5*dxq(ij,l) - dxq(ij,l)= - , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) - ENDDO - - ENDDO ! l=1,llm -cprint*,'Ok calcul des pentes' - - ELSE ! (pente_max.lt.-1.e-5) - -c Pentes produits: -c ---------------- - - DO l = 1, llm - DO ij=iip2,ip1jm-1 - dxqu(ij)=q(ij+1,l)-q(ij,l) - ENDDO - DO ij=iip1+iip1,ip1jm,iip1 - dxqu(ij)=dxqu(ij-iim) - ENDDO - - DO ij=iip2+1,ip1jm - zz(ij)=dxqu(ij-1)*dxqu(ij) - zz(ij)=zz(ij)+zz(ij) - IF(zz(ij).gt.0) THEN - dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) - ELSE -c extremum local - dxq(ij,l)=0. - ENDIF - ENDDO - - ENDDO - - ENDIF ! (pente_max.lt.-1.e-5) - -c bouclage de la pente en iip1: -c ----------------------------- - - DO l=1,llm - DO ij=iip1+iip1,ip1jm,iip1 - dxq(ij-iim,l)=dxq(ij,l) - ENDDO - DO ij=1,ip1jmp1 - iadvplus(ij,l)=0 - ENDDO - - ENDDO - -c print*,'Bouclage en iip1' - -c calcul des flux a gauche et a droite - -#ifdef CRAY - - DO l=1,llm - DO ij=iip2,ip1jm-1 - zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), - , 1.+u_m(ij,l)/masse(ij+1,l), - , u_m(ij,l)) - zdum(ij,l)=0.5*zdum(ij,l) - u_mq(ij,l)=cvmgp( - , q(ij,l)+zdum(ij,l)*dxq(ij,l), - , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), - , u_m(ij,l)) - u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) - ENDDO - ENDDO -#else -c on cumule le flux correspondant a toutes les mailles dont la masse -c au travers de la paroi pENDant le pas de temps. -cprint*,'Cumule ....' - - DO l=1,llm - DO ij=iip2,ip1jm-1 -c print*,'masse(',ij,')=',masse(ij,l) - IF (u_m(ij,l).gt.0.) THEN - zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) - u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l)) - ELSE - zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) - u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l)) - ENDIF - ENDDO - ENDDO -#endif -c stop - -c go to 9999 -c detection des points ou on advecte plus que la masse de la -c maille - DO l=1,llm - DO ij=iip2,ip1jm-1 - IF(zdum(ij,l).lt.0) THEN - iadvplus(ij,l)=1 - u_mq(ij,l)=0. - ENDIF - ENDDO - ENDDO -cprint*,'Ok test 1' - DO l=1,llm - DO ij=iip1+iip1,ip1jm,iip1 - iadvplus(ij,l)=iadvplus(ij-iim,l) - ENDDO - ENDDO -c print*,'Ok test 2' - - -c traitement special pour le cas ou on advecte en longitude plus que le -c contenu de la maille. -c cette partie est mal vectorisee. - -c calcul du nombre de maille sur lequel on advecte plus que la maille. - - n0=0 - DO l=1,llm - nl(l)=0 - DO ij=iip2,ip1jm - nl(l)=nl(l)+iadvplus(ij,l) - ENDDO - n0=n0+nl(l) - ENDDO - -cym IF(n0.gt.1) THEN - IF(n0.gt.0) THEN - - PRINT*,'Nombre de points pour lesquels on advect plus que le' - & ,'contenu de la maille : ',n0 - - DO l=1,llm - IF(nl(l).gt.0) THEN - iju=0 -c indicage des mailles concernees par le traitement special - DO ij=iip2,ip1jm - IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN - iju=iju+1 - indu(iju)=ij - ENDIF - ENDDO - niju=iju -c PRINT*,'niju,nl',niju,nl(l) - -c traitement des mailles - DO iju=1,niju - ij=indu(iju) - j=(ij-1)/iip1+1 - zu_m=u_m(ij,l) - u_mq(ij,l)=0. - IF(zu_m.gt.0.) THEN - ijq=ij - i=ijq-(j-1)*iip1 -c accumulation pour les mailles completements advectees - do while(zu_m.gt.masse(ijq,l)) - u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) - zu_m=zu_m-masse(ijq,l) - i=mod(i-2+iim,iim)+1 - ijq=(j-1)*iip1+i - ENDDO -c ajout de la maille non completement advectee - u_mq(ij,l)=u_mq(ij,l)+zu_m* - & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) - ELSE - ijq=ij+1 - i=ijq-(j-1)*iip1 -c accumulation pour les mailles completements advectees - do while(-zu_m.gt.masse(ijq,l)) - u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) - zu_m=zu_m+masse(ijq,l) - i=mod(i,iim)+1 - ijq=(j-1)*iip1+i - ENDDO -c ajout de la maille non completement advectee - u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- - & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF ! n0.gt.0 -9999 continue - - -c bouclage en latitude -cprint*,'cvant bouclage en latitude' - DO l=1,llm - DO ij=iip1+iip1,ip1jm,iip1 - u_mq(ij,l)=u_mq(ij-iim,l) - ENDDO - ENDDO - - -c calcul des tENDances - - DO l=1,llm - DO ij=iip2+1,ip1jm - new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) - q(ij,l)=(q(ij,l)*masse(ij,l)+ - & u_mq(ij-1,l)-u_mq(ij,l)) - & /new_m - masse(ij,l)=new_m - ENDDO -c ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous) - DO ij=iip1+iip1,ip1jm,iip1 - q(ij-iim,l)=q(ij,l) - masse(ij-iim,l)=masse(ij,l) - ENDDO - ENDDO -c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) -c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) - - - RETURN - END - SUBROUTINE vly(q,pente_max,masse,masse_adv_v) -c -c Auteurs: P.Le Van, F.Hourdin, F.Forget -c -c ******************************************************************** -c Shema d'advection " pseudo amont " . -c ******************************************************************** -c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... -c dq sont des arguments de sortie pour le s-pg .... -c -c -c -------------------------------------------------------------------- - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "logic.h" -#include "comvert.h" -#include "comconst.h" -#include "comgeom.h" -c -c -c Arguments: -c ---------- - REAL masse(ip1jmp1,llm),pente_max - REAL masse_adv_v( ip1jm,llm) - REAL q(ip1jmp1,llm), dq( ip1jmp1,llm) -c -c Local -c --------- -c - INTEGER i,ij,l -c - REAL airej2,airejjm,airescb(iim),airesch(iim) - REAL dyq(ip1jmp1,llm),dyqv(ip1jm),zdvm(ip1jmp1,llm) - REAL adyqv(ip1jm),dyqmax(ip1jmp1) - REAL qbyv(ip1jm,llm) - - REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs -c REAL newq,oldmasse - Logical extremum,first,testcpu - REAL temps0,temps1,temps2,temps3,temps4,temps5,second - SAVE temps0,temps1,temps2,temps3,temps4,temps5 - SAVE first,testcpu - - REAL convpn,convps,convmpn,convmps - real massepn,masseps,qpn,qps - REAL sinlon(iip1),sinlondlon(iip1) - REAL coslon(iip1),coslondlon(iip1) - SAVE sinlon,coslon,sinlondlon,coslondlon - SAVE airej2,airejjm -c -c - REAL SSUM - - DATA first,testcpu/.true.,.false./ - DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ - - IF(first) THEN - PRINT*,'Shema Amont nouveau appele dans Vanleer ' - first=.false. - do i=2,iip1 - coslon(i)=cos(rlonv(i)) - sinlon(i)=sin(rlonv(i)) - coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi - sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi - ENDDO - coslon(1)=coslon(iip1) - coslondlon(1)=coslondlon(iip1) - sinlon(1)=sinlon(iip1) - sinlondlon(1)=sinlondlon(iip1) - airej2 = SSUM( iim, aire(iip2), 1 ) - airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) - ENDIF - -c -cPRINT*,'CALCUL EN LATITUDE' - - DO l = 1, llm -c -c -------------------------------- -c CALCUL EN LATITUDE -c -------------------------------- - -c On commence par calculer la valeur du traceur moyenne sur le premier cercle -c de latitude autour du pole (qpns pour le pole nord et qpsn pour -c le pole nord) qui sera utilisee pour evaluer les pentes au pole. - - DO i = 1, iim - airescb(i) = aire(i+ iip1) * q(i+ iip1,l) - airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) - ENDDO - qpns = SSUM( iim, airescb ,1 ) / airej2 - qpsn = SSUM( iim, airesch ,1 ) / airejjm - -c calcul des pentes aux points v - - DO ij=1,ip1jm - dyqv(ij)=q(ij,l)-q(ij+iip1,l) - adyqv(ij)=abs(dyqv(ij)) - ENDDO - -c calcul des pentes aux points scalaires - - DO ij=iip2,ip1jm - dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) - dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) - dyqmax(ij)=pente_max*dyqmax(ij) - ENDDO - -c calcul des pentes aux poles - - DO ij=1,iip1 - dyq(ij,l)=qpns-q(ij+iip1,l) - dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn - ENDDO - -c filtrage de la derivee - dyn1=0. - dys1=0. - dyn2=0. - dys2=0. - DO ij=1,iim - dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) - dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) - dyn2=dyn2+coslondlon(ij)*dyq(ij,l) - dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) - ENDDO - DO ij=1,iip1 - dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) - dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) - ENDDO - -c calcul des pentes limites aux poles - - goto 8888 - fn=1. - fs=1. - DO ij=1,iim - IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN - fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) - ENDIF - IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN - fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) - ENDIF - ENDDO - DO ij=1,iip1 - dyq(ij,l)=fn*dyq(ij,l) - dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) - ENDDO -8888 continue - DO ij=1,iip1 - dyq(ij,l)=0. - dyq(ip1jm+ij,l)=0. - ENDDO - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C En memoire de dIFferents tests sur la -C limitation des pentes aux poles. -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PRINT*,dyq(1) -C PRINT*,dyqv(iip1+1) -C apn=abs(dyq(1)/dyqv(iip1+1)) -C PRINT*,dyq(ip1jm+1) -C PRINT*,dyqv(ip1jm-iip1+1) -C aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) -C DO ij=2,iim -C apn=amax1(abs(dyq(ij)/dyqv(ij)),apn) -C aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps) -C ENDDO -C apn=min(pente_max/apn,1.) -C aps=min(pente_max/aps,1.) -C -C -C cas ou on a un extremum au pole -C -C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) -C & apn=0. -C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* -C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) -C & aps=0. -C -C limitation des pentes aux poles -C DO ij=1,iip1 -C dyq(ij)=apn*dyq(ij) -C dyq(ip1jm+ij)=aps*dyq(ip1jm+ij) -C ENDDO -C -C test -C DO ij=1,iip1 -C dyq(iip1+ij)=0. -C dyq(ip1jm+ij-iip1)=0. -C ENDDO -C DO ij=1,ip1jmp1 -C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) -C ENDDO -C -C changement 10 07 96 -C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) -C & THEN -C DO ij=1,iip1 -C dyqmax(ij)=0. -C ENDDO -C ELSE -C DO ij=1,iip1 -C dyqmax(ij)=pente_max*abs(dyqv(ij)) -C ENDDO -C ENDIF -C -C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* -C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) -C &THEN -C DO ij=ip1jm+1,ip1jmp1 -C dyqmax(ij)=0. -C ENDDO -C ELSE -C DO ij=ip1jm+1,ip1jmp1 -C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) -C ENDDO -C ENDIF -C fin changement 10 07 96 -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -c calcul des pentes limitees - - DO ij=iip2,ip1jm - IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN - dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) - ELSE - dyq(ij,l)=0. - ENDIF - ENDDO - - ENDDO - - DO l=1,llm - DO ij=1,ip1jm - IF(masse_adv_v(ij,l).gt.0) THEN - qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)* - , 0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)) - ELSE - qbyv(ij,l)=q(ij,l)-dyq(ij,l)* - , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) - ENDIF - qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l) - ENDDO - ENDDO - - - DO l=1,llm - DO ij=iip2,ip1jm - newmasse=masse(ij,l) - & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) - q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) - & /newmasse - masse(ij,l)=newmasse - ENDDO -c.-. ancienne version -c convpn=SSUM(iim,qbyv(1,l),1)/apoln -c convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln - - convpn=SSUM(iim,qbyv(1,l),1) - convmpn=ssum(iim,masse_adv_v(1,l),1) - massepn=ssum(iim,masse(1,l),1) - qpn=0. - do ij=1,iim - qpn=qpn+masse(ij,l)*q(ij,l) - enddo - qpn=(qpn+convpn)/(massepn+convmpn) - do ij=1,iip1 - q(ij,l)=qpn - enddo - -c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols -c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols - - convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) - convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) - masseps=ssum(iim, masse(ip1jm+1,l),1) - qps=0. - do ij = ip1jm+1,ip1jmp1-1 - qps=qps+masse(ij,l)*q(ij,l) - enddo - qps=(qps+convps)/(masseps+convmps) - do ij=ip1jm+1,ip1jmp1 - q(ij,l)=qps - enddo - -c.-. fin ancienne version - -c._. nouvelle version -c convpn=SSUM(iim,qbyv(1,l),1) -c convmpn=ssum(iim,masse_adv_v(1,l),1) -c oldmasse=ssum(iim,masse(1,l),1) -c newmasse=oldmasse+convmpn -c newq=(q(1,l)*oldmasse+convpn)/newmasse -c newmasse=newmasse/apoln -c DO ij = 1,iip1 -c q(ij,l)=newq -c masse(ij,l)=newmasse*aire(ij) -c ENDDO -c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) -c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) -c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) -c newmasse=oldmasse+convmps -c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse -c newmasse=newmasse/apols -c DO ij = ip1jm+1,ip1jmp1 -c q(ij,l)=newq -c masse(ij,l)=newmasse*aire(ij) -c ENDDO -c._. fin nouvelle version - ENDDO - - RETURN - END - SUBROUTINE vlz(q,pente_max,masse,w) -c -c Auteurs: P.Le Van, F.Hourdin, F.Forget -c -c ******************************************************************** -c Shema d'advection " pseudo amont " . -c ******************************************************************** -c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... -c dq sont des arguments de sortie pour le s-pg .... -c -c -c -------------------------------------------------------------------- - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "logic.h" -#include "comvert.h" -#include "comconst.h" -c -c -c Arguments: -c ---------- - REAL masse(ip1jmp1,llm),pente_max - REAL q(ip1jmp1,llm) - REAL w(ip1jmp1,llm+1) -c -c Local -c --------- -c - INTEGER i,ij,l,j,ii -c - REAL wq(ip1jmp1,llm+1),newmasse - - REAL dzq(ip1jmp1,llm),dzqw(ip1jmp1,llm),adzqw(ip1jmp1,llm),dzqmax - REAL sigw - - LOGICAL testcpu - SAVE testcpu - - REAL temps0,temps1,temps2,temps3,temps4,temps5,second - SAVE temps0,temps1,temps2,temps3,temps4,temps5 - REAL SSUM - - DATA testcpu/.false./ - DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ - -c On oriente tout dans le sens de la pression c'est a dire dans le -c sens de W - -#ifdef BIDON - IF(testcpu) THEN - temps0=second(0.) - ENDIF -#endif - DO l=2,llm - DO ij=1,ip1jmp1 - dzqw(ij,l)=q(ij,l-1)-q(ij,l) - adzqw(ij,l)=abs(dzqw(ij,l)) - ENDDO - ENDDO - - DO l=2,llm-1 - DO ij=1,ip1jmp1 -#ifdef CRAY - dzq(ij,l)=0.5* - , cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1)) -#else - IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN - dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1)) - ELSE - dzq(ij,l)=0. - ENDIF -#endif - dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1)) - dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l)) - ENDDO - ENDDO - - DO ij=1,ip1jmp1 - dzq(ij,1)=0. - dzq(ij,llm)=0. - ENDDO - -#ifdef BIDON - IF(testcpu) THEN - temps1=temps1+second(0.)-temps0 - ENDIF -#endif -c --------------------------------------------------------------- -c .... calcul des termes d'advection verticale ....... -c --------------------------------------------------------------- - -c calcul de - d( q * w )/ d(sigma) qu'on ajoute a dq pour calculer dq - - DO l = 1,llm-1 - do ij = 1,ip1jmp1 - IF(w(ij,l+1).gt.0.) THEN - sigw=w(ij,l+1)/masse(ij,l+1) - wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1)) - ELSE - sigw=w(ij,l+1)/masse(ij,l) - wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l)) - ENDIF - ENDDO - ENDDO - - DO ij=1,ip1jmp1 - wq(ij,llm+1)=0. - wq(ij,1)=0. - ENDDO - - DO l=1,llm - DO ij=1,ip1jmp1 - newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l) - q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l)) - & /newmasse - masse(ij,l)=newmasse - ENDDO - ENDDO - - - RETURN - END -c SUBROUTINE minmaxq(zq,qmin,qmax,comment) -c -c#include "dimensions.h" -c#include "paramet.h" - -c CHARACTER*(*) comment -c real qmin,qmax -c real zq(ip1jmp1,llm) - -c INTEGER jadrs(ip1jmp1), jbad, k, i - - -c DO k = 1, llm -c jbad = 0 -c DO i = 1, ip1jmp1 -c IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN -c jbad = jbad + 1 -c jadrs(jbad) = i -c ENDIF -c ENDDO -c IF (jbad.GT.0) THEN -c PRINT*, comment -c DO i = 1, jbad -cc PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k) -c ENDDO -c ENDIF -c ENDDO - -c return -c end - subroutine minmaxq(zq,qmin,qmax,comment) - -#include "dimensions.h" -#include "paramet.h" - - character*20 comment - real qmin,qmax - real zq(ip1jmp1,llm) - real zzq(iip1,jjp1,llm) - - integer imin,jmin,lmin,ijlmin - integer imax,jmax,lmax,ijlmax - - integer ismin,ismax - -#ifdef isminismax - call scopy (ip1jmp1*llm,zq,1,zzq,1) - - ijlmin=ismin(ijp1llm,zq,1) - lmin=(ijlmin-1)/ip1jmp1+1 - ijlmin=ijlmin-(lmin-1.)*ip1jmp1 - jmin=(ijlmin-1)/iip1+1 - imin=ijlmin-(jmin-1.)*iip1 - zqmin=zq(ijlmin,lmin) - - ijlmax=ismax(ijp1llm,zq,1) - lmax=(ijlmax-1)/ip1jmp1+1 - ijlmax=ijlmax-(lmax-1.)*ip1jmp1 - jmax=(ijlmax-1)/iip1+1 - imax=ijlmax-(jmax-1.)*iip1 - zqmax=zq(ijlmax,lmax) - - if(zqmin.lt.qmin) -c s write(*,9999) comment, - s write(*,*) comment, - s imin,jmin,lmin,zqmin,zzq(imin,jmin,lmin) - if(zqmax.gt.qmax) -c s write(*,9999) comment, - s write(*,*) comment, - s imax,jmax,lmax,zqmax,zzq(imax,jmax,lmax) - -#endif - return -9999 format(a20,' q(',i3,',',i2,',',i2,')=',e12.5,e12.5) - end - - - Index: LMDZ4/branches/V3_test/libf/dyn3dpar/vlspltqs.F =================================================================== --- LMDZ4/branches/V3_test/libf/dyn3dpar/vlspltqs.F (revision 706) +++ (revision ) @@ -1,776 +1,0 @@ -! -! $Header$ -! - SUBROUTINE vlspltqs ( q,pente_max,masse,w,pbaru,pbarv,pdt, - , p,pk,teta ) -c -c Auteurs: P.Le Van, F.Hourdin, F.Forget, F.Codron -c -c ******************************************************************** -c Shema d'advection " pseudo amont " . -c + test sur humidite specifique: Q advecte< Qsat aval -c (F. Codron, 10/99) -c ******************************************************************** -c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... -c -c pente_max facteur de limitation des pentes: 2 en general -c 0 pour un schema amont -c pbaru,pbarv,w flux de masse en u ,v ,w -c pdt pas de temps -c -c teta temperature potentielle, p pression aux interfaces, -c pk exner au milieu des couches necessaire pour calculer Qsat -c -------------------------------------------------------------------- - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "logic.h" -#include "comvert.h" -#include "comconst.h" - -c -c Arguments: -c ---------- - REAL masse(ip1jmp1,llm),pente_max - REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) - REAL q(ip1jmp1,llm) - REAL w(ip1jmp1,llm),pdt - REAL p(ip1jmp1,llmp1),teta(ip1jmp1,llm),pk(ip1jmp1,llm) -c -c Local -c --------- -c - INTEGER i,ij,l,j,ii -c - REAL qsat(ip1jmp1,llm) - REAL zm(ip1jmp1,llm) - REAL mu(ip1jmp1,llm) - REAL mv(ip1jm,llm) - REAL mw(ip1jmp1,llm+1) - REAL zq(ip1jmp1,llm) - REAL temps1,temps2,temps3 - REAL zzpbar, zzw - LOGICAL testcpu - SAVE testcpu - SAVE temps1,temps2,temps3 - - REAL qmin,qmax - DATA qmin,qmax/0.,1.e33/ - DATA testcpu/.false./ - DATA temps1,temps2,temps3/0.,0.,0./ - -c--pour rapport de melange saturant-- - - REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play - REAL ptarg,pdelarg,foeew,zdelta - REAL tempe(ip1jmp1) - -c fonction psat(T) - - FOEEW ( PTARG,PDELARG ) = EXP ( - * (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) - * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) ) - - r2es = 380.11733 - r3les = 17.269 - r3ies = 21.875 - r4les = 35.86 - r4ies = 7.66 - retv = 0.6077667 - rtt = 273.16 - -c-- Calcul de Qsat en chaque point -c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2 -c pour eviter une exponentielle. - DO l = 1, llm - DO ij = 1, ip1jmp1 - tempe(ij) = teta(ij,l) * pk(ij,l) /cpp - ENDDO - DO ij = 1, ip1jmp1 - zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) ) - play = 0.5*(p(ij,l)+p(ij,l+1)) - qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play ) - qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) ) - ENDDO - ENDDO - -c PRINT*,'Debut vlsplt version debug sans vlyqs' - - zzpbar = 0.5 * pdt - zzw = pdt - DO l=1,llm - DO ij = iip2,ip1jm - mu(ij,l)=pbaru(ij,l) * zzpbar - ENDDO - DO ij=1,ip1jm - mv(ij,l)=pbarv(ij,l) * zzpbar - ENDDO - DO ij=1,ip1jmp1 - mw(ij,l)=w(ij,l) * zzw - ENDDO - ENDDO - - DO ij=1,ip1jmp1 - mw(ij,llm+1)=0. - ENDDO - - CALL SCOPY(ijp1llm,q,1,zq,1) - CALL SCOPY(ijp1llm,masse,1,zm,1) - -c call minmaxq(zq,qmin,qmax,'avant vlxqs ') - call vlxqs(zq,pente_max,zm,mu,qsat) - - -c call minmaxq(zq,qmin,qmax,'avant vlyqs ') - - call vlyqs(zq,pente_max,zm,mv,qsat) - - -c call minmaxq(zq,qmin,qmax,'avant vlz ') - - call vlz(zq,pente_max,zm,mw) - - -c call minmaxq(zq,qmin,qmax,'avant vlyqs ') -c call minmaxq(zm,qmin,qmax,'M avant vlyqs ') - - call vlyqs(zq,pente_max,zm,mv,qsat) - - -c call minmaxq(zq,qmin,qmax,'avant vlxqs ') -c call minmaxq(zm,qmin,qmax,'M avant vlxqs ') - - call vlxqs(zq,pente_max,zm,mu,qsat) - -c call minmaxq(zq,qmin,qmax,'apres vlxqs ') -c call minmaxq(zm,qmin,qmax,'M apres vlxqs ') - - - DO l=1,llm - DO ij=1,ip1jmp1 - q(ij,l)=zq(ij,l) - ENDDO - DO ij=1,ip1jm+1,iip1 - q(ij+iim,l)=q(ij,l) - ENDDO - ENDDO - - RETURN - END - SUBROUTINE vlxqs(q,pente_max,masse,u_m,qsat) -c -c Auteurs: P.Le Van, F.Hourdin, F.Forget -c -c ******************************************************************** -c Shema d'advection " pseudo amont " . -c ******************************************************************** -c -c -------------------------------------------------------------------- - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "logic.h" -#include "comvert.h" -#include "comconst.h" -c -c -c Arguments: -c ---------- - REAL masse(ip1jmp1,llm),pente_max - REAL u_m( ip1jmp1,llm ) - REAL q(ip1jmp1,llm) - REAL qsat(ip1jmp1,llm) -c -c Local -c --------- -c - INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju - INTEGER n0,iadvplus(ip1jmp1,llm),nl(llm) -c - REAL new_m,zu_m,zdum(ip1jmp1,llm) - REAL dxq(ip1jmp1,llm),dxqu(ip1jmp1) - REAL zz(ip1jmp1) - REAL adxqu(ip1jmp1),dxqmax(ip1jmp1,llm) - REAL u_mq(ip1jmp1,llm) - - Logical first,testcpu - SAVE first,testcpu - - REAL SSUM - REAL temps0,temps1,temps2,temps3,temps4,temps5 - SAVE temps0,temps1,temps2,temps3,temps4,temps5 - - - DATA first,testcpu/.true.,.false./ - - IF(first) THEN - temps1=0. - temps2=0. - temps3=0. - temps4=0. - temps5=0. - first=.false. - ENDIF - -c calcul de la pente a droite et a gauche de la maille - - - IF (pente_max.gt.-1.e-5) THEN -c IF (pente_max.gt.10) THEN - -c calcul des pentes avec limitation, Van Leer scheme I: -c ----------------------------------------------------- - -c calcul de la pente aux points u - DO l = 1, llm - DO ij=iip2,ip1jm-1 - dxqu(ij)=q(ij+1,l)-q(ij,l) -c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' -c sigu(ij)=u_m(ij,l)/masse(ij,l) - ENDDO - DO ij=iip1+iip1,ip1jm,iip1 - dxqu(ij)=dxqu(ij-iim) -c sigu(ij)=sigu(ij-iim) - ENDDO - - DO ij=iip2,ip1jm - adxqu(ij)=abs(dxqu(ij)) - ENDDO - -c calcul de la pente maximum dans la maille en valeur absolue - - DO ij=iip2+1,ip1jm - dxqmax(ij,l)=pente_max* - , min(adxqu(ij-1),adxqu(ij)) -c limitation subtile -c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) - - - ENDDO - - DO ij=iip1+iip1,ip1jm,iip1 - dxqmax(ij-iim,l)=dxqmax(ij,l) - ENDDO - - DO ij=iip2+1,ip1jm -#ifdef CRAY - dxq(ij,l)= - , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) -#else - IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN - dxq(ij,l)=dxqu(ij-1)+dxqu(ij) - ELSE -c extremum local - dxq(ij,l)=0. - ENDIF -#endif - dxq(ij,l)=0.5*dxq(ij,l) - dxq(ij,l)= - , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) - ENDDO - - ENDDO ! l=1,llm - - ELSE ! (pente_max.lt.-1.e-5) - -c Pentes produits: -c ---------------- - - DO l = 1, llm - DO ij=iip2,ip1jm-1 - dxqu(ij)=q(ij+1,l)-q(ij,l) - ENDDO - DO ij=iip1+iip1,ip1jm,iip1 - dxqu(ij)=dxqu(ij-iim) - ENDDO - - DO ij=iip2+1,ip1jm - zz(ij)=dxqu(ij-1)*dxqu(ij) - zz(ij)=zz(ij)+zz(ij) - IF(zz(ij).gt.0) THEN - dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) - ELSE -c extremum local - dxq(ij,l)=0. - ENDIF - ENDDO - - ENDDO - - ENDIF ! (pente_max.lt.-1.e-5) - -c bouclage de la pente en iip1: -c ----------------------------- - - DO l=1,llm - DO ij=iip1+iip1,ip1jm,iip1 - dxq(ij-iim,l)=dxq(ij,l) - ENDDO - - DO ij=1,ip1jmp1 - iadvplus(ij,l)=0 - ENDDO - - ENDDO - - -c calcul des flux a gauche et a droite - -#ifdef CRAY -c--pas encore modification sur Qsat - DO l=1,llm - DO ij=iip2,ip1jm-1 - zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), - , 1.+u_m(ij,l)/masse(ij+1,l), - , u_m(ij,l)) - zdum(ij,l)=0.5*zdum(ij,l) - u_mq(ij,l)=cvmgp( - , q(ij,l)+zdum(ij,l)*dxq(ij,l), - , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), - , u_m(ij,l)) - u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) - ENDDO - ENDDO -#else -c on cumule le flux correspondant a toutes les mailles dont la masse -c au travers de la paroi pENDant le pas de temps. -c le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind) - DO l=1,llm - DO ij=iip2,ip1jm-1 - IF (u_m(ij,l).gt.0.) THEN - zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) - u_mq(ij,l)=u_m(ij,l)* - $ min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l)) - ELSE - zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) - u_mq(ij,l)=u_m(ij,l)* - $ min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l)) - ENDIF - ENDDO - ENDDO -#endif - - -c detection des points ou on advecte plus que la masse de la -c maille - DO l=1,llm - DO ij=iip2,ip1jm-1 - IF(zdum(ij,l).lt.0) THEN - iadvplus(ij,l)=1 - u_mq(ij,l)=0. - ENDIF - ENDDO - ENDDO - DO l=1,llm - DO ij=iip1+iip1,ip1jm,iip1 - iadvplus(ij,l)=iadvplus(ij-iim,l) - ENDDO - ENDDO - - - -c traitement special pour le cas ou on advecte en longitude plus que le -c contenu de la maille. -c cette partie est mal vectorisee. - -c pas d'influence de la pression saturante (pour l'instant) - -c calcul du nombre de maille sur lequel on advecte plus que la maille. - - n0=0 - DO l=1,llm - nl(l)=0 - DO ij=iip2,ip1jm - nl(l)=nl(l)+iadvplus(ij,l) - ENDDO - n0=n0+nl(l) - ENDDO - -cym IF(n0.gt.1) THEN - IF(n0.gt.0) THEN -ccc PRINT*,'Nombre de points pour lesquels on advect plus que le' -ccc & ,'contenu de la maille : ',n0 - - DO l=1,llm - IF(nl(l).gt.0) THEN - iju=0 -c indicage des mailles concernees par le traitement special - DO ij=iip2,ip1jm - IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN - iju=iju+1 - indu(iju)=ij - ENDIF - ENDDO - niju=iju -c PRINT*,'niju,nl',niju,nl(l) - -c traitement des mailles - DO iju=1,niju - ij=indu(iju) - j=(ij-1)/iip1+1 - zu_m=u_m(ij,l) - u_mq(ij,l)=0. - IF(zu_m.gt.0.) THEN - ijq=ij - i=ijq-(j-1)*iip1 -c accumulation pour les mailles completements advectees - do while(zu_m.gt.masse(ijq,l)) - u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) - zu_m=zu_m-masse(ijq,l) - i=mod(i-2+iim,iim)+1 - ijq=(j-1)*iip1+i - ENDDO -c ajout de la maille non completement advectee - u_mq(ij,l)=u_mq(ij,l)+zu_m* - & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) - ELSE - ijq=ij+1 - i=ijq-(j-1)*iip1 -c accumulation pour les mailles completements advectees - do while(-zu_m.gt.masse(ijq,l)) - u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) - zu_m=zu_m+masse(ijq,l) - i=mod(i,iim)+1 - ijq=(j-1)*iip1+i - ENDDO -c ajout de la maille non completement advectee - u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- - & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) - ENDIF - ENDDO - ENDIF - ENDDO - ENDIF ! n0.gt.0 - - - -c bouclage en latitude - - DO l=1,llm - DO ij=iip1+iip1,ip1jm,iip1 - u_mq(ij,l)=u_mq(ij-iim,l) - ENDDO - ENDDO - - -c calcul des tendances - - DO l=1,llm - DO ij=iip2+1,ip1jm - new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) - q(ij,l)=(q(ij,l)*masse(ij,l)+ - & u_mq(ij-1,l)-u_mq(ij,l)) - & /new_m - masse(ij,l)=new_m - ENDDO -c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous) - DO ij=iip1+iip1,ip1jm,iip1 - q(ij-iim,l)=q(ij,l) - masse(ij-iim,l)=masse(ij,l) - ENDDO - ENDDO - -c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) -c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) - - - RETURN - END - SUBROUTINE vlyqs(q,pente_max,masse,masse_adv_v,qsat) -c -c Auteurs: P.Le Van, F.Hourdin, F.Forget -c -c ******************************************************************** -c Shema d'advection " pseudo amont " . -c ******************************************************************** -c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... -c qsat est un argument de sortie pour le s-pg .... -c -c -c -------------------------------------------------------------------- - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "logic.h" -#include "comvert.h" -#include "comconst.h" -#include "comgeom.h" -c -c -c Arguments: -c ---------- - REAL masse(ip1jmp1,llm),pente_max - REAL masse_adv_v( ip1jm,llm) - REAL q(ip1jmp1,llm) - REAL qsat(ip1jmp1,llm) -c -c Local -c --------- -c - INTEGER i,ij,l -c - REAL airej2,airejjm,airescb(iim),airesch(iim) - REAL dyq(ip1jmp1,llm),dyqv(ip1jm) - REAL adyqv(ip1jm),dyqmax(ip1jmp1) - REAL qbyv(ip1jm,llm) - - REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs -c REAL newq,oldmasse - Logical first,testcpu - REAL temps0,temps1,temps2,temps3,temps4,temps5 - SAVE temps0,temps1,temps2,temps3,temps4,temps5 - SAVE first,testcpu - - REAL convpn,convps,convmpn,convmps - REAL sinlon(iip1),sinlondlon(iip1) - REAL coslon(iip1),coslondlon(iip1) - SAVE sinlon,coslon,sinlondlon,coslondlon - SAVE airej2,airejjm -c -c - REAL SSUM - - DATA first,testcpu/.true.,.false./ - DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ - - IF(first) THEN - PRINT*,'Shema Amont nouveau appele dans Vanleer ' - first=.false. - do i=2,iip1 - coslon(i)=cos(rlonv(i)) - sinlon(i)=sin(rlonv(i)) - coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi - sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi - ENDDO - coslon(1)=coslon(iip1) - coslondlon(1)=coslondlon(iip1) - sinlon(1)=sinlon(iip1) - sinlondlon(1)=sinlondlon(iip1) - airej2 = SSUM( iim, aire(iip2), 1 ) - airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) - ENDIF - -c - - - DO l = 1, llm -c -c -------------------------------- -c CALCUL EN LATITUDE -c -------------------------------- - -c On commence par calculer la valeur du traceur moyenne sur le premier cercle -c de latitude autour du pole (qpns pour le pole nord et qpsn pour -c le pole nord) qui sera utilisee pour evaluer les pentes au pole. - - DO i = 1, iim - airescb(i) = aire(i+ iip1) * q(i+ iip1,l) - airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) - ENDDO - qpns = SSUM( iim, airescb ,1 ) / airej2 - qpsn = SSUM( iim, airesch ,1 ) / airejjm - -c calcul des pentes aux points v - - DO ij=1,ip1jm - dyqv(ij)=q(ij,l)-q(ij+iip1,l) - adyqv(ij)=abs(dyqv(ij)) - ENDDO - -c calcul des pentes aux points scalaires - - DO ij=iip2,ip1jm - dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) - dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) - dyqmax(ij)=pente_max*dyqmax(ij) - ENDDO - -c calcul des pentes aux poles - - DO ij=1,iip1 - dyq(ij,l)=qpns-q(ij+iip1,l) - dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn - ENDDO - -c filtrage de la derivee - dyn1=0. - dys1=0. - dyn2=0. - dys2=0. - DO ij=1,iim - dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) - dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) - dyn2=dyn2+coslondlon(ij)*dyq(ij,l) - dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) - ENDDO - DO ij=1,iip1 - dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) - dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) - ENDDO - -c calcul des pentes limites aux poles - - fn=1. - fs=1. - DO ij=1,iim - IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN - fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) - ENDIF - IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN - fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) - ENDIF - ENDDO - DO ij=1,iip1 - dyq(ij,l)=fn*dyq(ij,l) - dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) - ENDDO - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C En memoire de dIFferents tests sur la -C limitation des pentes aux poles. -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C PRINT*,dyq(1) -C PRINT*,dyqv(iip1+1) -C apn=abs(dyq(1)/dyqv(iip1+1)) -C PRINT*,dyq(ip1jm+1) -C PRINT*,dyqv(ip1jm-iip1+1) -C aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) -C DO ij=2,iim -C apn=amax1(abs(dyq(ij)/dyqv(ij)),apn) -C aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps) -C ENDDO -C apn=min(pente_max/apn,1.) -C aps=min(pente_max/aps,1.) -C -C -C cas ou on a un extremum au pole -C -C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) -C & apn=0. -C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* -C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) -C & aps=0. -C -C limitation des pentes aux poles -C DO ij=1,iip1 -C dyq(ij)=apn*dyq(ij) -C dyq(ip1jm+ij)=aps*dyq(ip1jm+ij) -C ENDDO -C -C test -C DO ij=1,iip1 -C dyq(iip1+ij)=0. -C dyq(ip1jm+ij-iip1)=0. -C ENDDO -C DO ij=1,ip1jmp1 -C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) -C ENDDO -C -C changement 10 07 96 -C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) -C & THEN -C DO ij=1,iip1 -C dyqmax(ij)=0. -C ENDDO -C ELSE -C DO ij=1,iip1 -C dyqmax(ij)=pente_max*abs(dyqv(ij)) -C ENDDO -C ENDIF -C -C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* -C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) -C &THEN -C DO ij=ip1jm+1,ip1jmp1 -C dyqmax(ij)=0. -C ENDDO -C ELSE -C DO ij=ip1jm+1,ip1jmp1 -C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) -C ENDDO -C ENDIF -C fin changement 10 07 96 -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -c calcul des pentes limitees - - DO ij=iip2,ip1jm - IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN - dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) - ELSE - dyq(ij,l)=0. - ENDIF - ENDDO - - ENDDO - - DO l=1,llm - DO ij=1,ip1jm - IF( masse_adv_v(ij,l).GT.0. ) THEN - qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l ) + - , dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))) - ELSE - qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) * - , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) ) - ENDIF - qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l) - ENDDO - ENDDO - - - DO l=1,llm - DO ij=iip2,ip1jm - newmasse=masse(ij,l) - & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) - q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) - & /newmasse - masse(ij,l)=newmasse - ENDDO -c.-. ancienne version - convpn=SSUM(iim,qbyv(1,l),1)/apoln - convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln - DO ij = 1,iip1 - newmasse=masse(ij,l)+convmpn*aire(ij) - q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/ - & newmasse - masse(ij,l)=newmasse - ENDDO - convps = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols - convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols - DO ij = ip1jm+1,ip1jmp1 - newmasse=masse(ij,l)+convmps*aire(ij) - q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/ - & newmasse - masse(ij,l)=newmasse - ENDDO -c.-. fin ancienne version - -c._. nouvelle version -c convpn=SSUM(iim,qbyv(1,l),1) -c convmpn=ssum(iim,masse_adv_v(1,l),1) -c oldmasse=ssum(iim,masse(1,l),1) -c newmasse=oldmasse+convmpn -c newq=(q(1,l)*oldmasse+convpn)/newmasse -c newmasse=newmasse/apoln -c DO ij = 1,iip1 -c q(ij,l)=newq -c masse(ij,l)=newmasse*aire(ij) -c ENDDO -c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) -c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) -c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) -c newmasse=oldmasse+convmps -c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse -c newmasse=newmasse/apols -c DO ij = ip1jm+1,ip1jmp1 -c q(ij,l)=newq -c masse(ij,l)=newmasse*aire(ij) -c ENDDO -c._. fin nouvelle version - ENDDO - - RETURN - END