Index: LMDZ5/trunk/libf/dyn3dmem/PVtheta.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/PVtheta.F (revision 1944) +++ (revision ) @@ -1,196 +1,0 @@ - SUBROUTINE PVtheta(ilon,ilev,pucov,pvcov,pteta, - $ ztfi,zplay,zplev, - $ nbteta,theta,PVteta) - IMPLICIT none - -c======================================================================= -c -c Auteur: I. Musat -c ------- -c -c Objet: -c ------ -c -c ******************************************************************* -c Calcul de la vorticite potentielle PVteta sur des iso-theta selon -c la methodologie du NCEP/NCAR : -c 1) on calcule la stabilite statique N**2=g/T*(dT/dz+g/cp) sur les -c niveaux du modele => N2 -c 2) on interpole les vents, la temperature et le N**2 sur des isentropes -c (en fait sur des iso-theta) lineairement en log(theta) => -c ucovteta, vcovteta, N2teta -c 3) on calcule la vorticite absolue sur des iso-theta => vorateta -c 4) on calcule la densite rho sur des iso-theta => rhoteta -c -c rhoteta = (T/theta)**(cp/R)*p0/(R*T) -c -c 5) on calcule la vorticite potentielle sur des iso-theta => PVteta -c -c PVteta = (vorateta * N2 * theta)/(g * rhoteta) ! en PVU -c -c NB: 1PVU=10**(-6) K*m**2/(s * kg) -c -c PVteta = vorateta * N2/(g**2 * rhoteta) ! en 1/(Pa*s) -c -c -c ******************************************************************* -c -c -c Variables d'entree : ilon,ilev,pucov,pvcov,pteta,ztfi,zplay,zplev,nbteta,theta -c -> sur la grille dynamique -c Variable de sortie : PVteta -c -> sur la grille physique -c======================================================================= - -#include "dimensions.h" -#include "paramet.h" -c -c variables Input -c - INTEGER ilon, ilev - REAL pvcov(iip1,jjm,ilev) - REAL pucov(iip1,jjp1,ilev) - REAL pteta(iip1,jjp1,ilev) - REAL ztfi(ilon,ilev) - REAL zplay(ilon,ilev), zplev(ilon,ilev+1) - INTEGER nbteta - REAL theta(nbteta) -c -c variable Output -c - REAL PVteta(ilon,nbteta) -c -c variables locales -c - INTEGER i, j, l, ig0 - REAL SSUM - REAL teta(ilon, ilev) - REAL ptetau(ip1jmp1, ilev), ptetav(ip1jm, ilev) - REAL ucovteta(ip1jmp1,ilev), vcovteta(ip1jm,ilev) - REAL N2(ilon,ilev-1), N2teta(ilon,nbteta) - REAL ztfiteta(ilon,nbteta) - REAL rhoteta(ilon,nbteta) - REAL vorateta(iip1,jjm,nbteta) - REAL voratetafi(ilon,nbteta), vorpol(iim) -c -#include "comgeom2.h" -#include "comconst.h" -#include "comvert.h" -c -c projection teta sur la grille physique -c - DO l=1,llm - teta(1,l) = pteta(1,1,l) - ig0 = 2 - DO j = 2, jjm - DO i = 1, iim - teta(ig0,l) = pteta(i,j,l) - ig0 = ig0 + 1 - ENDDO - ENDDO - teta(ig0,l) = pteta(1,jjp1,l) - ENDDO -c -c calcul pteta sur les grilles U et V -c - DO l=1, llm - DO j=1, jjp1 - DO i=1, iip1 - ig0=i+(j-1)*iip1 - ptetau(ig0,l)=pteta(i,j,l) - ENDDO !i - ENDDO !j - DO j=1, jjm - DO i=1, iip1 - ig0=i+(j-1)*iip1 - ptetav(ig0,l)=0.5*(pteta(i,j,l)+pteta(i,j+1,l)) - ENDDO !i - ENDDO !j - ENDDO !l -c -c projection pucov, pvcov sur une surface de theta constante -c - DO l=1, nbteta -cIM 1rout CALL tetaleveli1j1(ip1jmp1,llm,.true.,ptetau,theta(l), - CALL tetalevel(ip1jmp1,llm,.true.,ptetau,theta(l), - . pucov,ucovteta(:,l)) -cIM 1rout CALL tetaleveli1j(ip1jm,llm,.true.,ptetav,theta(l), - CALL tetalevel(ip1jm,llm,.true.,ptetav,theta(l), - . pvcov,vcovteta(:,l)) - ENDDO !l -c -c calcul vorticite absolue sur une iso-theta : vorateta -c - CALL tourabs(nbteta,vcovteta,ucovteta,vorateta) -c -c projection vorateta sur la grille physique => voratetafi -c - DO l=1,nbteta - DO j=2,jjm - ig0=1+(j-2)*iim - DO i=1,iim - voratetafi(ig0+i+1,l) = vorateta( i ,j-1,l) * alpha4(i+1,j) + - $ vorateta(i+1,j-1,l) * alpha1(i+1,j) + - $ vorateta(i ,j ,l) * alpha3(i+1,j) + - $ vorateta(i+1,j ,l) * alpha2(i+1,j) - ENDDO - voratetafi(ig0 +1,l) = voratetafi(ig0 +1+ iim,l) - ENDDO - ENDDO -c - DO l=1,nbteta - DO i=1,iim - vorpol(i) = vorateta(i,1,l)*aire(i,1) - ENDDO - voratetafi(1,l)= SSUM(iim,vorpol,1)/apoln - ENDDO -c - DO l=1,nbteta - DO i=1,iim - vorpol(i) = vorateta(i,jjm,l)* aire(i,jjm +1) - ENDDO - voratetafi(ilon,l)= SSUM(iim,vorpol,1)/apols - ENDDO -c -c calcul N**2 sur la grille physique => N2 -c - DO l=1, llm-1 - DO i=1, ilon - N2(i,l) = (g**2 * zplay(i,l) * - $ (ztfi(i,l+1)-ztfi(i,l)) )/ - $ (R*ztfi(i,l)*ztfi(i,l)* - $ (zplev(i,l)-zplev(i,l+1)) )+ - $ (g**2)/(ztfi(i,l)*CPP) - ENDDO !i - ENDDO !l -c -c calcul N2 sur une iso-theta => N2teta -c - DO l=1, nbteta - CALL tetalevel(ilon,llm-1,.true.,teta,theta(l), - $ N2,N2teta(:,l)) - CALL tetalevel(ilon,llm,.true.,teta,theta(l), - $ ztfi,ztfiteta(:,l)) - ENDDO !l=1, nbteta -c -c calcul rho et PV sur une iso-theta : rhoteta, PVteta -c - DO l=1, nbteta - DO i=1, ilon - rhoteta(i,l)=(ztfiteta(i,l)/theta(l))**(CPP/R)* - $ (preff/(R*ztfiteta(i,l))) -c -c PVteta en PVU -c - PVteta(i,l)=(theta(l)*g*voratetafi(i,l)*N2teta(i,l))/ - $ (g**2*rhoteta(i,l)) -c -c PVteta en 1/(Pa*s) -c - PVteta(i,l)=(voratetafi(i,l)*N2teta(i,l))/ - $ (g**2*rhoteta(i,l)) - ENDDO !i - ENDDO !l -c - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/advn.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/advn.F (revision 1944) +++ (revision ) @@ -1,983 +1,0 @@ -! -! $Header$ -! - SUBROUTINE advn(q,masse,w,pbaru,pbarv,pdt,mode) -c -c Auteur : F. Hourdin -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 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" -#include "comgeom.h" -#include "iniprint.h" - -c -c Arguments: -c ---------- - integer mode - real masse(ip1jmp1,llm) - REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) - REAL q(ip1jmp1,llm) - REAL w(ip1jmp1,llm),pdt -c -c Local -c --------- -c - INTEGER i,ij,l,j,ii - integer ijlqmin,iqmin,jqmin,lqmin - integer ismin -c - real zm(ip1jmp1,llm),newmasse - real mu(ip1jmp1,llm) - real mv(ip1jm,llm) - real mw(ip1jmp1,llm+1) - real zq(ip1jmp1,llm),zz,qpn,qps - real zqg(ip1jmp1,llm),zqd(ip1jmp1,llm) - real zqs(ip1jmp1,llm),zqn(ip1jmp1,llm) - real zqh(ip1jmp1,llm),zqb(ip1jmp1,llm) - real temps0,temps1,temps2,temps3 - real ztemps1,ztemps2,ztemps3,ssum - logical testcpu - save testcpu - save temps1,temps2,temps3 - real zzpbar,zzw - -#ifdef CRAY - real second -#endif - - real qmin,qmax - data qmin,qmax/0.,1./ - 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 - - do l=1,llm - qpn=0. - qps=0. - do ij=1,iim - qpn=qpn+q(ij,l)*masse(ij,l) - qps=qps+q(ip1jm+ij,l)*masse(ip1jm+ij,l) - enddo - qpn=qpn/ssum(iim,masse(1,l),1) - qps=qps/ssum(iim,masse(ip1jm+1,l),1) - do ij=1,iip1 - q(ij,l)=qpn - q(ip1jm+ij,l)=qps - enddo - enddo - - do ij=1,ip1jmp1 - mw(ij,llm+1)=0. - enddo - do l=1,llm - do ij=1,ip1jmp1 - zq(ij,l)=q(ij,l) - zm(ij,l)=masse(ij,l) - enddo - enddo - -c call minmaxq(zq,qmin,qmax,'avant vlx ') - call advnqx(zq,zqg,zqd) - call advnx(zq,zqg,zqd,zm,mu,mode) - call advnqy(zq,zqs,zqn) - call advny(zq,zqs,zqn,zm,mv) - call advnqz(zq,zqh,zqb) - call advnz(zq,zqh,zqb,zm,mw) -c call vlz(zq,0.,zm,mw) - call advnqy(zq,zqs,zqn) - call advny(zq,zqs,zqn,zm,mv) - call advnqx(zq,zqg,zqd) - call advnx(zq,zqg,zqd,zm,mu,mode) -c call minmaxq(zq,qmin,qmax,'apres vlx ') - -#ifdef CRAY - if(testcpu) then - ztemps1=second(0.) - temps1=temps1+ztemps1-ztemps2 - print*,'VLSPLT X:',temps1,' Y:',temps2,' Z:',temps3 - endif -#endif - 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 advnqx(q,qg,qd) -c -c Auteurs: Calcul des valeurs de q aux point u. -c -c -------------------------------------------------------------------- - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "iniprint.h" -c -c -c Arguments: -c ---------- - real q(ip1jmp1,llm),qg(ip1jmp1,llm),qd(ip1jmp1,llm) -c -c Local -c --------- -c - INTEGER ij,l -c - real dxqu(ip1jmp1),zqu(ip1jmp1) - real zqmax(ip1jmp1),zqmin(ip1jmp1) - logical extremum(ip1jmp1) - - integer mode - save mode - data mode/1/ - -c calcul des pentes en u: -c ----------------------- - if (mode.eq.0) then - do l=1,llm - do ij=1,ip1jm - qd(ij,l)=q(ij,l) - qg(ij,l)=q(ij,l) - enddo - enddo - else - do l = 1, llm - do ij=iip2,ip1jm-1 - dxqu(ij)=q(ij+1,l)-q(ij,l) - zqu(ij)=0.5*(q(ij+1,l)+q(ij,l)) - enddo - do ij=iip1+iip1,ip1jm,iip1 - dxqu(ij)=dxqu(ij-iim) - zqu(ij)=zqu(ij-iim) - enddo - do ij=iip2,ip1jm-1 - zqu(ij)=zqu(ij)-dxqu(ij+1)/12. - enddo - do ij=iip1+iip1,ip1jm,iip1 - zqu(ij)=zqu(ij-iim) - enddo - do ij=iip2+1,ip1jm - zqu(ij)=zqu(ij)+dxqu(ij-1)/12. - enddo - do ij=iip1+iip1,ip1jm,iip1 - zqu(ij-iim)=zqu(ij) - enddo - -c calcul des valeurs max et min acceptees aux interfaces - - do ij=iip2,ip1jm-1 - zqmax(ij)=max(q(ij+1,l),q(ij,l)) - zqmin(ij)=min(q(ij+1,l),q(ij,l)) - enddo - do ij=iip1+iip1,ip1jm,iip1 - zqmax(ij)=zqmax(ij-iim) - zqmin(ij)=zqmin(ij-iim) - enddo - do ij=iip2+1,ip1jm - extremum(ij)=dxqu(ij)*dxqu(ij-1).le.0. - enddo - do ij=iip1+iip1,ip1jm,iip1 - extremum(ij-iim)=extremum(ij) - enddo - do ij=iip2,ip1jm - zqu(ij)=min(max(zqmin(ij),zqu(ij)),zqmax(ij)) - enddo - do ij=iip2+1,ip1jm - if(extremum(ij)) then - qg(ij,l)=q(ij,l) - qd(ij,l)=q(ij,l) - else - qd(ij,l)=zqu(ij) - qg(ij,l)=zqu(ij-1) - endif - enddo - do ij=iip1+iip1,ip1jm,iip1 - qd(ij-iim,l)=qd(ij,l) - qg(ij-iim,l)=qg(ij,l) - enddo - - goto 8888 - - do ij=iip2+1,ip1jm - if(extremum(ij).and..not.extremum(ij-1)) - s qd(ij-1,l)=q(ij,l) - enddo - - do ij=iip1+iip1,ip1jm,iip1 - qd(ij-iim,l)=qd(ij,l) - enddo - do ij=iip2,ip1jm-1 - if (extremum(ij).and..not.extremum(ij+1)) - s qg(ij+1,l)=q(ij,l) - enddo - - do ij=iip1+iip1,ip1jm,iip1 - qg(ij,l)=qg(ij-iim,l) - enddo -8888 continue - enddo - endif - RETURN - END - SUBROUTINE advnqy(q,qs,qn) -c -c Auteurs: Calcul des valeurs de q aux point v. -c -c -------------------------------------------------------------------- - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "iniprint.h" -c -c -c Arguments: -c ---------- - real q(ip1jmp1,llm),qs(ip1jmp1,llm),qn(ip1jmp1,llm) -c -c Local -c --------- -c - INTEGER ij,l -c - real dyqv(ip1jm),zqv(ip1jm,llm) - real zqmax(ip1jm),zqmin(ip1jm) - logical extremum(ip1jmp1) - - integer mode - save mode - data mode/1/ - - if (mode.eq.0) then - do l=1,llm - do ij=1,ip1jmp1 - qn(ij,l)=q(ij,l) - qs(ij,l)=q(ij,l) - enddo - enddo - else - -c calcul des pentes en u: -c ----------------------- - do l = 1, llm - do ij=1,ip1jm - dyqv(ij)=q(ij,l)-q(ij+iip1,l) - enddo - - do ij=iip2,ip1jm-iip1 - zqv(ij,l)=0.5*(q(ij+iip1,l)+q(ij,l)) - zqv(ij,l)=zqv(ij,l)+(dyqv(ij+iip1)-dyqv(ij-iip1))/12. - enddo - - do ij=iip2,ip1jm - extremum(ij)=dyqv(ij)*dyqv(ij-iip1).le.0. - enddo - -c Pas de pentes aux poles - do ij=1,iip1 - zqv(ij,l)=q(ij,l) - zqv(ip1jm-iip1+ij,l)=q(ip1jm+ij,l) - extremum(ij)=.true. - extremum(ip1jmp1-iip1+ij)=.true. - enddo - -c calcul des valeurs max et min acceptees aux interfaces - do ij=1,ip1jm - zqmax(ij)=max(q(ij+iip1,l),q(ij,l)) - zqmin(ij)=min(q(ij+iip1,l),q(ij,l)) - enddo - - do ij=1,ip1jm - zqv(ij,l)=min(max(zqmin(ij),zqv(ij,l)),zqmax(ij)) - enddo - - do ij=iip2,ip1jm - if(extremum(ij)) then - qs(ij,l)=q(ij,l) - qn(ij,l)=q(ij,l) -c if (.not.extremum(ij-iip1)) qs(ij-iip1,l)=q(ij,l) -c if (.not.extremum(ij+iip1)) qn(ij+iip1,l)=q(ij,l) - else - qs(ij,l)=zqv(ij,l) - qn(ij,l)=zqv(ij-iip1,l) - endif - enddo - - do ij=1,iip1 - qs(ij,l)=q(ij,l) - qn(ij,l)=q(ij,l) - qs(ip1jm+ij,l)=q(ip1jm+ij,l) - qn(ip1jm+ij,l)=q(ip1jm+ij,l) - enddo - - enddo - endif - RETURN - END - - SUBROUTINE advnqz(q,qh,qb) -c -c Auteurs: Calcul des valeurs de q aux point v. -c -c -------------------------------------------------------------------- - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "iniprint.h" -c -c -c Arguments: -c ---------- - real q(ip1jmp1,llm),qh(ip1jmp1,llm),qb(ip1jmp1,llm) -c -c Local -c --------- -c - INTEGER ij,l -c - real dzqw(ip1jmp1,llm+1),zqw(ip1jmp1,llm+1) - real zqmax(ip1jmp1,llm),zqmin(ip1jmp1,llm) - logical extremum(ip1jmp1,llm) - - integer mode - save mode - - data mode/1/ - -c calcul des pentes en u: -c ----------------------- - - if (mode.eq.0) then - do l=1,llm - do ij=1,ip1jmp1 - qb(ij,l)=q(ij,l) - qh(ij,l)=q(ij,l) - enddo - enddo - else - do l = 2, llm - do ij=1,ip1jmp1 - dzqw(ij,l)=q(ij,l-1)-q(ij,l) - zqw(ij,l)=0.5*(q(ij,l-1)+q(ij,l)) - enddo - enddo - do ij=1,ip1jmp1 - dzqw(ij,1)=0. - dzqw(ij,llm+1)=0. - enddo - do l=2,llm - do ij=1,ip1jmp1 - zqw(ij,l)=zqw(ij,l)+(dzqw(ij,l+1)-dzqw(ij,l-1))/12. - enddo - enddo - do l=2,llm-1 - do ij=1,ip1jmp1 - extremum(ij,l)=dzqw(ij,l)*dzqw(ij,l+1).le.0. - enddo - enddo - -c Pas de pentes en bas et en haut - do ij=1,ip1jmp1 - zqw(ij,2)=q(ij,1) - zqw(ij,llm)=q(ij,llm) - extremum(ij,1)=.true. - extremum(ij,llm)=.true. - enddo - -c calcul des valeurs max et min acceptees aux interfaces - do l=2,llm - do ij=1,ip1jmp1 - zqmax(ij,l)=max(q(ij,l-1),q(ij,l)) - zqmin(ij,l)=min(q(ij,l-1),q(ij,l)) - enddo - enddo - - do l=2,llm - do ij=1,ip1jmp1 - zqw(ij,l)=min(max(zqmin(ij,l),zqw(ij,l)),zqmax(ij,l)) - enddo - enddo - - do l=2,llm-1 - do ij=1,ip1jmp1 - if(extremum(ij,l)) then - qh(ij,l)=q(ij,l) - qb(ij,l)=q(ij,l) - else - qh(ij,l)=zqw(ij,l+1) - qb(ij,l)=zqw(ij,l) - endif - enddo - enddo -c do l=2,llm-1 -c do ij=1,ip1jmp1 -c if(extremum(ij,l)) then -c if (.not.extremum(ij,l-1)) qh(ij,l-1)=q(ij,l) -c if (.not.extremum(ij,l+1)) qb(ij,l+1)=q(ij,l) -c endif -c enddo -c enddo - - do ij=1,ip1jmp1 - qb(ij,1)=q(ij,1) - qh(ij,1)=q(ij,1) - qb(ij,llm)=q(ij,llm) - qh(ij,llm)=q(ij,llm) - enddo - - endif - - RETURN - END - - SUBROUTINE advnx(q,qg,qd,masse,u_m,mode) -c -c Auteur : F. Hourdin -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" -#include "iniprint.h" -c -c -c Arguments: -c ---------- - integer mode - real masse(ip1jmp1,llm) - real u_m( ip1jmp1,llm ) - real q(ip1jmp1,llm),qd(ip1jmp1,llm),qg(ip1jmp1,llm) -c -c Local -c --------- -c - INTEGER i,j,ij,l,indu(ip1jmp1),niju,iju,ijq - integer n0,nl(llm) -c - real new_m,zu_m,zdq,zz - real zsigg(ip1jmp1,llm),zsigd(ip1jmp1,llm),zsig - real u_mq(ip1jmp1,llm) - - real zm,zq,zsigm,zsigp,zqm,zqp,zu - - logical ladvplus(ip1jmp1,llm) - - real prec - save prec - -#ifdef CRAY - data prec/1.e-24/ -#else - data prec/1.e-15/ -#endif - - do l=1,llm - do ij=iip2,ip1jm - zdq=qd(ij,l)-qg(ij,l) -c if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) then -c print*,'probleme au point ij=',ij,' l=',l -c print*,qd(ij,l),q(ij,l),qg(ij,l) -c qd(ij,l)=q(ij,l) -c qg(ij,l)=q(ij,l) -c endif - if(abs(zdq).gt.prec) then - zsigd(ij,l)=(q(ij,l)-qg(ij,l))/zdq - zsigg(ij,l)=1.-zsigd(ij,l) -c if(.not.(zsigd(ij,l).ge.0..and.zsigd(ij,l).le.1. .and. -c s zsigg(ij,l).ge.0..or.zsigg(ij,l).le.1.) ) then -c print*,'probleme au point ij=',ij,' l=',l -c print*,'sigg=',zsigg(ij,l),' sigd=',zsigd(ij,l) -c print*,'q d,c,g ',qd(ij,l),q(ij,l),qg(ij,l),zdq -c stop -c endif - else - zsigd(ij,l)=0.5 - zsigg(ij,l)=0.5 - qd(ij,l)=q(ij,l) - qg(ij,l)=q(ij,l) - endif - enddo - enddo - -c calcul de la pente maximum dans la maille en valeur absolue - - do l=1,llm - do ij=iip2,ip1jm-1 - if (u_m(ij,l).ge.0.) then - zsigp=zsigd(ij,l) - zsigm=zsigg(ij,l) - zqp=qd(ij,l) - zqm=qg(ij,l) - zm=masse(ij,l) - zq=q(ij,l) - else - zsigm=zsigd(ij+1,l) - zsigp=zsigg(ij+1,l) - zqm=qd(ij+1,l) - zqp=qg(ij+1,l) - zm=masse(ij+1,l) - zq=q(ij+1,l) - endif - zu=abs(u_m(ij,l)) - ladvplus(ij,l)=zu.gt.zm - zsig=zu/zm - if(zsig.eq.0.) zsigp=0.1 - if (mode.eq.1) then - if (zsig.le.zsigp) then - u_mq(ij,l)=u_m(ij,l)*zqp - else if (mode.eq.1) then - u_mq(ij,l)= - s sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm) - endif - else - if (zsig.le.zsigp) then - u_mq(ij,l)=u_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) - else - zz=0.5*(zsig-zsigp)/zsigm - u_mq(ij,l)=sign(zm,u_m(ij,l))*( 0.5*(zq+zqp)*zsigp - s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) - endif - endif -c if(zsig.lt.0.) then -c print*,'au point ij=',ij,' l=',l,' sig=',zsig -c stop -c endif - enddo - enddo - - do l=1,llm - do ij=iip1+iip1,ip1jm,iip1 - u_mq(ij,l)=u_mq(ij-iim,l) - ladvplus(ij,l)=ladvplus(ij-iim,l) - enddo - enddo - -c================================================================= -C SCHEMA SEMI-LAGRAGIEN EN X DANS LES REGIONS POLAIRES -c================================================================= -c tris des regions a traiter - n0=0 - do l=1,llm - nl(l)=0 - do ij=iip2,ip1jm - if(ladvplus(ij,l)) then - nl(l)=nl(l)+1 - u_mq(ij,l)=0. - endif - enddo - n0=n0+nl(l) - enddo - - if(n0.gt.1) then - IF (prt_level > 9) WRITE(lunout,*) - & '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(ladvplus(ij,l).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 MODIFS SPECIFIQUES DU SCHEMA -c ajout de la maille non completement advectee - zsig=zu_m/masse(ijq,l) - if(zsig.le.zsigd(ijq,l)) then - u_mq(ij,l)=u_mq(ij,l)+zu_m*(qd(ijq,l) - s -0.5*zsig/zsigd(ijq,l)*(qd(ijq,l)-q(ijq,l))) - else -c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) -c goto 8888 - zz=0.5*(zsig-zsigd(ijq,l))/zsigg(ijq,l) - if(.not.(zz.gt.0..and.zz.le.0.5)) then - WRITE(lunout,*)'probleme2 au point ij=',ij, - s ' l=',l - WRITE(lunout,*)'zz=',zz - stop - endif - u_mq(ij,l)=u_mq(ij,l)+masse(ijq,l)*( - s 0.5*(q(ijq,l)+qd(ijq,l))*zsigd(ijq,l) - s +(zsig-zsigd(ijq,l))*(q(ijq,l)+zz*(qg(ijq,l)-q(ijq,l))) ) - endif - 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 -c 2eme MODIF SPECIFIQUE - zsig=-zu_m/masse(ij+1,l) - if(zsig.le.zsigg(ijq,l)) then - u_mq(ij,l)=u_mq(ij,l)+zu_m*(qg(ijq,l) - s -0.5*zsig/zsigg(ijq,l)*(qg(ijq,l)-q(ijq,l))) - else -c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) -c goto 9999 - zz=0.5*(zsig-zsigg(ijq,l))/zsigd(ijq,l) - if(.not.(zz.gt.0..and.zz.le.0.5)) then - WRITE(lunout,*)'probleme22 au point ij=',ij - s ,' l=',l - WRITE(lunout,*)'zz=',zz - stop - endif - u_mq(ij,l)=u_mq(ij,l)-masse(ijq,l)*( - s 0.5*(q(ijq,l)+qg(ijq,l))*zsigg(ijq,l) - s +(zsig-zsigg(ijq,l))* - s (q(ijq,l)+zz*(qd(ijq,l)-q(ijq,l))) ) - endif -c fin de la modif - 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================================================================= -c CALCUL DE LA CONVERGENCE DES FLUX -c================================================================= - - 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 - - RETURN - END - SUBROUTINE advny(q,qs,qn,masse,v_m) -c -c Auteur : F. Hourdin -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 "comgeom.h" -#include "iniprint.h" -c -c -c Arguments: -c ---------- - real masse(ip1jmp1,llm) - real v_m( ip1jm,llm ) - real q(ip1jmp1,llm),qn(ip1jmp1,llm),qs(ip1jmp1,llm) -c -c Local -c --------- -c - INTEGER ij,l -c - real new_m,zdq,zz - real zsigs(ip1jmp1),zsign(ip1jmp1),zsig - real v_mq(ip1jm,llm) - real convpn,convps,convmpn,convmps,massen,masses - real zm,zq,zsigm,zsigp,zqm,zqp - real ssum - real prec - save prec - -#ifdef CRAY - data prec/1.e-24/ -#else - data prec/1.e-15/ -#endif - do l=1,llm - do ij=1,ip1jmp1 - zdq=qn(ij,l)-qs(ij,l) -c if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) then -c print*,'probleme au point ij=',ij,' l=',l,' advnqx' -c print*,qn(ij,l),q(ij,l),qs(ij,l) -c qn(ij,l)=q(ij,l) -c qs(ij,l)=q(ij,l) -c endif - if(abs(zdq).gt.prec) then - zsign(ij)=(q(ij,l)-qs(ij,l))/zdq - zsigs(ij)=1.-zsign(ij) -c if(.not.(zsign(ij).ge.0..and.zsign(ij).le.1. .and. -c s zsigs(ij).ge.0..or.zsigs(ij).le.1.) ) then -c print*,'probleme au point ij=',ij,' l=',l -c print*,'sigs=',zsigs(ij),' sign=',zsign(ij) -c stop -c endif - else - zsign(ij)=0.5 - zsigs(ij)=0.5 - endif - enddo - -c calcul de la pente maximum dans la maille en valeur absolue - - do ij=1,ip1jm - if (v_m(ij,l).ge.0.) then - zsigp=zsign(ij+iip1) - zsigm=zsigs(ij+iip1) - zqp=qn(ij+iip1,l) - zqm=qs(ij+iip1,l) - zm=masse(ij+iip1,l) - zq=q(ij+iip1,l) - else - zsigm=zsign(ij) - zsigp=zsigs(ij) - zqm=qn(ij,l) - zqp=qs(ij,l) - zm=masse(ij,l) - zq=q(ij,l) - endif - zsig=abs(v_m(ij,l))/zm - if(zsig.eq.0.) zsigp=0.1 - if (zsig.le.zsigp) then - v_mq(ij,l)=v_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) - else - zz=0.5*(zsig-zsigp)/zsigm - v_mq(ij,l)=sign(zm,v_m(ij,l))*( 0.5*(zq+zqp)*zsigp - s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) - endif - enddo - enddo - - do l=1,llm - do ij=iip2,ip1jm - new_m=masse(ij,l) - & +v_m(ij,l)-v_m(ij-iip1,l) - q(ij,l)=(q(ij,l)*masse(ij,l)+v_mq(ij,l)-v_mq(ij-iip1,l)) - & /new_m - masse(ij,l)=new_m - enddo -c.-. ancienne version - convpn=SSUM(iim,v_mq(1,l),1) - convmpn=ssum(iim,v_m(1,l),1) - massen=ssum(iim,masse(1,l),1) - new_m=massen+convmpn - q(1,l)=(q(1,l)*massen+convpn)/new_m - do ij = 1,iip1 - q(ij,l)=q(1,l) - masse(ij,l)=new_m*aire(ij)/apoln - enddo - - convps=-SSUM(iim,v_mq(ip1jm-iim,l),1) - convmps=-ssum(iim,v_m(ip1jm-iim,l),1) - masses=ssum(iim,masse(ip1jm+1,l),1) - new_m=masses+convmps - q(ip1jm+1,l)=(q(ip1jm+1,l)*masses+convps)/new_m - do ij = ip1jm+1,ip1jmp1 - q(ij,l)=q(ip1jm+1,l) - masse(ij,l)=new_m*aire(ij)/apols - enddo - enddo - - RETURN - END - SUBROUTINE advnz(q,qh,qb,masse,w_m) -c -c Auteurs: F.Hourdin -c -c ******************************************************************** -c Shema d'advection " pseudo amont " . -c b designe le bas et h le haut -c il y a une correspondance entre le b en z et le d en x -c ******************************************************************** -c -c -c -------------------------------------------------------------------- - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" -#include "iniprint.h" -c -c -c Arguments: -c ---------- - real masse(ip1jmp1,llm) - real w_m( ip1jmp1,llm+1) - real q(ip1jmp1,llm),qb(ip1jmp1,llm),qh(ip1jmp1,llm) - -c -c Local -c --------- -c - INTEGER ij,l -c - real new_m,zdq,zz - real zsigh(ip1jmp1,llm),zsigb(ip1jmp1,llm),zsig - real w_mq(ip1jmp1,llm+1) - real zm,zq,zsigm,zsigp,zqm,zqp - real prec - save prec - -#ifdef CRAY - data prec/1.e-24/ -#else - data prec/1.e-13/ -#endif - - do l=1,llm - do ij=1,ip1jmp1 - zdq=qb(ij,l)-qh(ij,l) -c if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) then -c print*,'probleme au point ij=',ij,' l=',l -c print*,qh(ij,l),q(ij,l),qb(ij,l) -c qh(ij,l)=q(ij,l) -c qb(ij,l)=q(ij,l) -c endif - - if(abs(zdq).gt.prec) then - zsigb(ij,l)=(q(ij,l)-qh(ij,l))/zdq - zsigh(ij,l)=1.-zsigb(ij,l) - zsigb(ij,l)=min(max(zsigb(ij,l),0.),1.) - else - zsigb(ij,l)=0.5 - zsigh(ij,l)=0.5 - endif - enddo - enddo - -c print*,'ok1' -c calcul de la pente maximum dans la maille en valeur absolue - do l=2,llm - do ij=1,ip1jmp1 - if (w_m(ij,l).ge.0.) then - zsigp=zsigb(ij,l) - zsigm=zsigh(ij,l) - zqp=qb(ij,l) - zqm=qh(ij,l) - zm=masse(ij,l) - zq=q(ij,l) - else - zsigm=zsigb(ij,l-1) - zsigp=zsigh(ij,l-1) - zqm=qb(ij,l-1) - zqp=qh(ij,l-1) - zm=masse(ij,l-1) - zq=q(ij,l-1) - endif - zsig=abs(w_m(ij,l))/zm - if(zsig.eq.0.) zsigp=0.1 - if (zsig.le.zsigp) then - w_mq(ij,l)=w_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) - else - zz=0.5*(zsig-zsigp)/zsigm - w_mq(ij,l)=sign(zm,w_m(ij,l))*( 0.5*(zq+zqp)*zsigp - s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) - endif - enddo - enddo - - do ij=1,ip1jmp1 - w_mq(ij,llm+1)=0. - w_mq(ij,1)=0. - enddo - - do l=1,llm - do ij=1,ip1jmp1 - new_m=masse(ij,l)+w_m(ij,l+1)-w_m(ij,l) - q(ij,l)=(q(ij,l)*masse(ij,l)+w_mq(ij,l+1)-w_mq(ij,l)) - & /new_m - masse(ij,l)=new_m - enddo - enddo -c print*,'ok3' - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/advxp.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/advxp.F (revision 1944) +++ (revision ) @@ -1,650 +1,0 @@ -! -! $Header$ -! - SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ - . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra) - IMPLICIT NONE -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C second-order moments (SOM) advection of tracer in X direction C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C parametres principaux du modele -C -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" - - INTEGER ntra -c PARAMETER (ntra = 1) -C -C definition de la grille du modele -C - REAL dtx - REAL pbaru ( iip1,jjp1,llm ) -C -C moments: SM total mass in each grid box -C S0 mass of tracer in each grid box -C Si 1rst order moment in i direction -C Sij 2nd order moment in i and j directions -C - REAL SM(iip1,jjp1,llm) - + ,S0(iip1,jjp1,llm,ntra) - REAL SSX(iip1,jjp1,llm,ntra) - + ,SY(iip1,jjp1,llm,ntra) - + ,SZ(iip1,jjp1,llm,ntra) - REAL SSXX(iip1,jjp1,llm,ntra) - + ,SSXY(iip1,jjp1,llm,ntra) - + ,SSXZ(iip1,jjp1,llm,ntra) - + ,SYY(iip1,jjp1,llm,ntra) - + ,SYZ(iip1,jjp1,llm,ntra) - + ,SZZ(iip1,jjp1,llm,ntra) - -C Local : -C ------- - -C mass fluxes across the boundaries (UGRI,VGRI,WGRI) -C mass fluxes in kg -C declaration : - - REAL UGRI(iip1,jjp1,llm) - -C Rem : VGRI et WGRI ne sont pas utilises dans -C cette subroutine ( advection en x uniquement ) -C -C -C Tij are the moments for the current latitude and level -C - REAL TM (iim) - REAL T0 (iim,NTRA),TX (iim,NTRA) - REAL TY (iim,NTRA),TZ (iim,NTRA) - REAL TXX(iim,NTRA),TXY(iim,NTRA) - REAL TXZ(iim,NTRA),TYY(iim,NTRA) - REAL TYZ(iim,NTRA),TZZ(iim,NTRA) -C -C the moments F are similarly defined and used as temporary -C storage for portions of the grid boxes in transit -C - REAL FM (iim) - REAL F0 (iim,NTRA),FX (iim,NTRA) - REAL FY (iim,NTRA),FZ (iim,NTRA) - REAL FXX(iim,NTRA),FXY(iim,NTRA) - REAL FXZ(iim,NTRA),FYY(iim,NTRA) - REAL FYZ(iim,NTRA),FZZ(iim,NTRA) -C -C work arrays -C - REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) - REAL ALF2(iim),ALF3(iim),ALF4(iim) -C - REAL SMNEW(iim),UEXT(iim) - REAL sqi,sqf - REAL TEMPTM - REAL SLPMAX - REAL S1MAX,S1NEW,S2NEW - - LOGICAL LIMIT - INTEGER NUM(jjp1),LONK,NUMK - INTEGER lon,lati,latf,niv - INTEGER i,i2,i3,j,jv,l,k,iter - - lon = iim - lati=2 - latf = jjm - niv = llm - -C *** Test de passage d'arguments ****** - -c DO 399 l = 1, llm -c DO 399 j = 1, jjp1 -c DO 399 i = 1, iip1 -c IF (S0(i,j,l,ntra) .lt. 0. ) THEN -c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) -c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) -c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) -c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) -c PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP' -cc STOP -c ENDIF -c 399 CONTINUE - -C *** Test : diagnostique de la qtite totale de traceur -C dans l'atmosphere avant l'advection -c - sqi =0. - sqf =0. -c - DO l = 1, llm - DO j = 1, jjp1 - DO i = 1, iim - sqi = sqi + S0(i,j,l,ntra) - END DO - END DO - END DO - PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----' - PRINT*,'sqi=',sqi -c test -c ------------------------------------- - DO 300 j =1,jjp1 - NUM(j) =1 - 300 CONTINUE -c DO l=1,llm -c NUM(2,l)=6 -c NUM(3,l)=6 -c NUM(jjm-1,l)=6 -c NUM(jjm,l)=6 -c ENDDO -c DO j=2,6 -c NUM(j)=12 -c ENDDO -c DO j=jjm-5,jjm-1 -c NUM(j)=12 -c ENDDO - -C Interface : adaptation nouveau modele -C ------------------------------------- -C -C --------------------------------------------------------- -C Conversion des flux de masses en kg/s -C pbaru est en N/s d'ou : -C ugri est en kg/s - - DO 500 l = 1,llm - DO 500 j = 1,jjp1 - DO 500 i = 1,iip1 - ugri (i,j,llm+1-l) =pbaru (i,j,l) - 500 CONTINUE - -C --------------------------------------------------------- -C start here -C -C boucle principale sur les niveaux et les latitudes -C - DO 1 L=1,NIV - DO 1 K=lati,latf - -C -C initialisation -C -C program assumes periodic boundaries in X -C - DO 10 I=2,LON - SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX - 10 CONTINUE - SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX -C -C modifications for extended polar zones -C - NUMK=NUM(K) - LONK=LON/NUMK -C - IF(NUMK.GT.1) THEN -C - DO 111 I=1,LON - TM(I)=0. - 111 CONTINUE - DO 112 JV=1,NTRA - DO 1120 I=1,LON - T0 (I,JV)=0. - TX (I,JV)=0. - TY (I,JV)=0. - TZ (I,JV)=0. - TXX(I,JV)=0. - TXY(I,JV)=0. - TXZ(I,JV)=0. - TYY(I,JV)=0. - TYZ(I,JV)=0. - TZZ(I,JV)=0. - 1120 CONTINUE - 112 CONTINUE -C - DO 11 I2=1,NUMK -C - DO 113 I=1,LONK - I3=(I-1)*NUMK+I2 - TM(I)=TM(I)+SM(I3,K,L) - ALF(I)=SM(I3,K,L)/TM(I) - ALF1(I)=1.-ALF(I) - ALFQ(I)=ALF(I)*ALF(I) - ALF1Q(I)=ALF1(I)*ALF1(I) - ALF2(I)=ALF1(I)-ALF(I) - ALF3(I)=ALF(I)*ALF1(I) - 113 CONTINUE -C - DO 114 JV=1,NTRA - DO 1140 I=1,LONK - I3=(I-1)*NUMK+I2 - TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV) - T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV) - TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV) - + +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) - TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM - TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV) - + +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV)) - TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV) - + +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV)) - TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV) - TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV) - TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV) - TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV) - TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV) - 1140 CONTINUE - 114 CONTINUE -C - 11 CONTINUE -C - ELSE -C - DO 115 I=1,LON - TM(I)=SM(I,K,L) - 115 CONTINUE - DO 116 JV=1,NTRA - DO 1160 I=1,LON - T0 (I,JV)=S0 (I,K,L,JV) - TX (I,JV)=SSX (I,K,L,JV) - TY (I,JV)=SY (I,K,L,JV) - TZ (I,JV)=SZ (I,K,L,JV) - TXX(I,JV)=SSXX(I,K,L,JV) - TXY(I,JV)=SSXY(I,K,L,JV) - TXZ(I,JV)=SSXZ(I,K,L,JV) - TYY(I,JV)=SYY(I,K,L,JV) - TYZ(I,JV)=SYZ(I,K,L,JV) - TZZ(I,JV)=SZZ(I,K,L,JV) - 1160 CONTINUE - 116 CONTINUE -C - ENDIF -C - DO 117 I=1,LONK - UEXT(I)=UGRI(I*NUMK,K,L) - 117 CONTINUE -C -C place limits on appropriate moments before transport -C (if flux-limiting is to be applied) -C - IF(.NOT.LIMIT) GO TO 13 -C - DO 12 JV=1,NTRA - DO 120 I=1,LONK - IF(T0(I,JV).GT.0.) THEN - SLPMAX=T0(I,JV) - S1MAX=1.5*SLPMAX - S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV))) - S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , - + AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) ) - TX (I,JV)=S1NEW - TXX(I,JV)=S2NEW - TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV))) - TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV))) - ELSE - TX (I,JV)=0. - TXX(I,JV)=0. - TXY(I,JV)=0. - TXZ(I,JV)=0. - ENDIF - 120 CONTINUE - 12 CONTINUE -C - 13 CONTINUE -C -C calculate flux and moments between adjacent boxes -C 1- create temporary moments/masses for partial boxes in transit -C 2- reajusts moments remaining in the box -C -C flux from IP to I if U(I).lt.0 -C - DO 140 I=1,LONK-1 - IF(UEXT(I).LT.0.) THEN - FM(I)=-UEXT(I)*DTX - ALF(I)=FM(I)/TM(I+1) - TM(I+1)=TM(I+1)-FM(I) - ENDIF - 140 CONTINUE -C - I=LONK - IF(UEXT(I).LT.0.) THEN - FM(I)=-UEXT(I)*DTX - ALF(I)=FM(I)/TM(1) - TM(1)=TM(1)-FM(I) - ENDIF -C -C flux from I to IP if U(I).gt.0 -C - DO 141 I=1,LONK - IF(UEXT(I).GE.0.) THEN - FM(I)=UEXT(I)*DTX - ALF(I)=FM(I)/TM(I) - TM(I)=TM(I)-FM(I) - ENDIF - 141 CONTINUE -C - DO 142 I=1,LONK - ALFQ(I)=ALF(I)*ALF(I) - ALF1(I)=1.-ALF(I) - ALF1Q(I)=ALF1(I)*ALF1(I) - ALF2(I)=ALF1(I)-ALF(I) - ALF3(I)=ALF(I)*ALFQ(I) - ALF4(I)=ALF1(I)*ALF1Q(I) - 142 CONTINUE -C - DO 150 JV=1,NTRA - DO 1500 I=1,LONK-1 -C - IF(UEXT(I).LT.0.) THEN -C - F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)* - + ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) ) - FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV)) - FXX(I,JV)=ALF3(I)*TXX(I+1,JV) - FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV)) - FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV)) - FXY(I,JV)=ALFQ(I)*TXY(I+1,JV) - FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV) - FYY(I,JV)=ALF (I)*TYY(I+1,JV) - FYZ(I,JV)=ALF (I)*TYZ(I+1,JV) - FZZ(I,JV)=ALF (I)*TZZ(I+1,JV) -C - T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV) - TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV)) - TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV) - TY (I+1,JV)=TY (I+1,JV)-FY (I,JV) - TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV) - TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV) - TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV) - TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV) - TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV) - TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV) -C - ENDIF -C - 1500 CONTINUE - 150 CONTINUE -C - I=LONK - IF(UEXT(I).LT.0.) THEN -C - DO 151 JV=1,NTRA -C - F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)* - + ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) ) - FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV)) - FXX(I,JV)=ALF3(I)*TXX(1,JV) - FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV)) - FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV)) - FXY(I,JV)=ALFQ(I)*TXY(1,JV) - FXZ(I,JV)=ALFQ(I)*TXZ(1,JV) - FYY(I,JV)=ALF (I)*TYY(1,JV) - FYZ(I,JV)=ALF (I)*TYZ(1,JV) - FZZ(I,JV)=ALF (I)*TZZ(1,JV) -C - T0 (1,JV)=T0(1,JV)-F0(I,JV) - TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV)) - TXX(1,JV)=ALF4(I)*TXX(1,JV) - TY (1,JV)=TY (1,JV)-FY (I,JV) - TZ (1,JV)=TZ (1,JV)-FZ (I,JV) - TYY(1,JV)=TYY(1,JV)-FYY(I,JV) - TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV) - TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV) - TXY(1,JV)=ALF1Q(I)*TXY(1,JV) - TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV) -C - 151 CONTINUE -C - ENDIF -C - DO 152 JV=1,NTRA - DO 1520 I=1,LONK -C - IF(UEXT(I).GE.0.) THEN -C - F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)* - + ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) ) - FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV)) - FXX(I,JV)=ALF3(I)*TXX(I,JV) - FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV)) - FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV)) - FXY(I,JV)=ALFQ(I)*TXY(I,JV) - FXZ(I,JV)=ALFQ(I)*TXZ(I,JV) - FYY(I,JV)=ALF (I)*TYY(I,JV) - FYZ(I,JV)=ALF (I)*TYZ(I,JV) - FZZ(I,JV)=ALF (I)*TZZ(I,JV) -C - T0 (I,JV)=T0(I,JV)-F0(I,JV) - TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV)) - TXX(I,JV)=ALF4(I)*TXX(I,JV) - TY (I,JV)=TY (I,JV)-FY (I,JV) - TZ (I,JV)=TZ (I,JV)-FZ (I,JV) - TYY(I,JV)=TYY(I,JV)-FYY(I,JV) - TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV) - TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV) - TXY(I,JV)=ALF1Q(I)*TXY(I,JV) - TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) -C - ENDIF -C - 1520 CONTINUE - 152 CONTINUE -C -C puts the temporary moments Fi into appropriate neighboring boxes -C - DO 160 I=1,LONK - IF(UEXT(I).LT.0.) THEN - TM(I)=TM(I)+FM(I) - ALF(I)=FM(I)/TM(I) - ENDIF - 160 CONTINUE -C - DO 161 I=1,LONK-1 - IF(UEXT(I).GE.0.) THEN - TM(I+1)=TM(I+1)+FM(I) - ALF(I)=FM(I)/TM(I+1) - ENDIF - 161 CONTINUE -C - I=LONK - IF(UEXT(I).GE.0.) THEN - TM(1)=TM(1)+FM(I) - ALF(I)=FM(I)/TM(1) - ENDIF -C - DO 162 I=1,LONK - ALF1(I)=1.-ALF(I) - ALFQ(I)=ALF(I)*ALF(I) - ALF1Q(I)=ALF1(I)*ALF1(I) - ALF2(I)=ALF1(I)-ALF(I) - ALF3(I)=ALF(I)*ALF1(I) - 162 CONTINUE -C - DO 170 JV=1,NTRA - DO 1700 I=1,LONK -C - IF(UEXT(I).LT.0.) THEN -C - TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV) - T0 (I,JV)=T0(I,JV)+F0(I,JV) - TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV) - + +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) - TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM - TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV) - + +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV)) - TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV) - + +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV)) - TY (I,JV)=TY (I,JV)+FY (I,JV) - TZ (I,JV)=TZ (I,JV)+FZ (I,JV) - TYY(I,JV)=TYY(I,JV)+FYY(I,JV) - TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV) - TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV) -C - ENDIF -C - 1700 CONTINUE - 170 CONTINUE -C - DO 171 JV=1,NTRA - DO 1710 I=1,LONK-1 -C - IF(UEXT(I).GE.0.) THEN -C - TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV) - T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV) - TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV) - + +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) - TX (I+1,JV)=ALF(I)*FX (I ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM - TXY(I+1,JV)=ALF(I)*FXY(I ,JV)+ALF1(I)*TXY(I+1,JV) - + +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I ,JV)) - TXZ(I+1,JV)=ALF(I)*FXZ(I ,JV)+ALF1(I)*TXZ(I+1,JV) - + +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I ,JV)) - TY (I+1,JV)=TY (I+1,JV)+FY (I,JV) - TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV) - TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV) - TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV) - TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV) -C - ENDIF -C - 1710 CONTINUE - 171 CONTINUE -C - I=LONK - IF(UEXT(I).GE.0.) THEN - DO 172 JV=1,NTRA - TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV) - T0 (1,JV)=T0(1,JV)+F0(I,JV) - TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV) - + +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) - TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM - TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV) - + +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV)) - TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV) - + +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV)) - TY (1,JV)=TY (1,JV)+FY (I,JV) - TZ (1,JV)=TZ (1,JV)+FZ (I,JV) - TYY(1,JV)=TYY(1,JV)+FYY(I,JV) - TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV) - TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV) - 172 CONTINUE - ENDIF -C -C retour aux mailles d'origine (passage des Tij aux Sij) -C - IF(NUMK.GT.1) THEN -C - DO 18 I2=1,NUMK -C - DO 180 I=1,LONK -C - I3=I2+(I-1)*NUMK - SM(I3,K,L)=SMNEW(I3) - ALF(I)=SMNEW(I3)/TM(I) - TM(I)=TM(I)-SMNEW(I3) -C - ALFQ(I)=ALF(I)*ALF(I) - ALF1(I)=1.-ALF(I) - ALF1Q(I)=ALF1(I)*ALF1(I) - ALF2(I)=ALF1(I)-ALF(I) - ALF3(I)=ALF(I)*ALFQ(I) - ALF4(I)=ALF1(I)*ALF1Q(I) -C - 180 CONTINUE -C - DO 181 JV=1,NTRA - DO 181 I=1,LONK -C - I3=I2+(I-1)*NUMK - S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)* - + ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) ) - SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV)) - SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV) - SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV)) - SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV)) - SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV) - SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV) - SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV) - SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV) - SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV) -C -C reajusts moments remaining in the box -C - T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV) - TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV)) - TXX(I,JV)=ALF4 (I)*TXX(I,JV) - TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV) - TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV) - TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV) - TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV) - TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV) - TXY(I,JV)=ALF1Q(I)*TXY(I,JV) - TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) -C - 181 CONTINUE -C - 18 CONTINUE -C - ELSE -C - DO 190 I=1,LON - SM(I,K,L)=TM(I) - 190 CONTINUE - DO 191 JV=1,NTRA - DO 1910 I=1,LON - S0 (I,K,L,JV)=T0 (I,JV) - SSX (I,K,L,JV)=TX (I,JV) - SY (I,K,L,JV)=TY (I,JV) - SZ (I,K,L,JV)=TZ (I,JV) - SSXX(I,K,L,JV)=TXX(I,JV) - SSXY(I,K,L,JV)=TXY(I,JV) - SSXZ(I,K,L,JV)=TXZ(I,JV) - SYY(I,K,L,JV)=TYY(I,JV) - SYZ(I,K,L,JV)=TYZ(I,JV) - SZZ(I,K,L,JV)=TZZ(I,JV) - 1910 CONTINUE - 191 CONTINUE -C - ENDIF -C - 1 CONTINUE -C -C ----------- AA Test en fin de ADVX ------ Controle des S* - -c DO 9999 l = 1, llm -c DO 9999 j = 1, jjp1 -c DO 9999 i = 1, iip1 -c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN -c PRINT*, '-------------------' -c PRINT*, 'En fin de ADVXP' -c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) -c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) -c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) -c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) -c WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP' -c STOP -c ENDIF -c 9999 CONTINUE -c ---------- bouclage cyclique - - DO l = 1,llm - DO j = 1,jjp1 - SM(iip1,j,l) = SM(1,j,l) - S0(iip1,j,l,ntra) = S0(1,j,l,ntra) - SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) - SY(iip1,j,l,ntra) = SY(1,j,l,ntra) - SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) - END DO - END DO - -C ----------- qqtite totale de traceur dans tte l'atmosphere - DO l = 1, llm - DO j = 1, jjp1 - DO i = 1, iim - sqf = sqf + S0(i,j,l,ntra) - END DO - END DO - END DO - - PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----' - PRINT*,'sqf=',sqf -c------------------------------------------------------------- - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/advy.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/advy.F (revision 1944) +++ (revision ) @@ -1,422 +1,0 @@ -! -! $Header$ -! - SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz) - IMPLICIT NONE - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C first-order moments (SOM) advection of tracer in Y direction C -C C -C Source : Pascal Simon ( Meteo, CNRM ) C -C Adaptation : A.A. (LGGE) C -C Derniere Modif : 15/12/94 LAST -C C -C sont les arguments d'entree pour le s-pg C -C C -C argument de sortie du s-pg C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Rem : Probleme aux poles il faut reecrire ce cas specifique -C Attention au sens de l'indexation -C -C parametres principaux du modele -C -C -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" -#include "comgeom2.h" - -C Arguments : -C ---------- -C dty : frequence fictive d'appel du transport -C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 - - INTEGER lon,lat,niv - INTEGER i,j,jv,k,kp,l - INTEGER ntra - PARAMETER (ntra = 1) - - REAL dty - REAL pbarv ( iip1,jjm, llm ) - -C moments: SM total mass in each grid box -C S0 mass of tracer in each grid box -C Si 1rst order moment in i direction -C - REAL SM(iip1,jjp1,llm) - + ,S0(iip1,jjp1,llm,ntra) - REAL sx(iip1,jjp1,llm,ntra) - + ,sy(iip1,jjp1,llm,ntra) - + ,sz(iip1,jjp1,llm,ntra) - - -C Local : -C ------- - -C mass fluxes across the boundaries (UGRI,VGRI,WGRI) -C mass fluxes in kg -C declaration : - - REAL VGRI(iip1,0:jjp1,llm) - -C Rem : UGRI et WGRI ne sont pas utilises dans -C cette subroutine ( advection en y uniquement ) -C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv -C -C the moments F are similarly defined and used as temporary -C storage for portions of the grid boxes in transit -C - REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) - REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) - REAL FZ(iim,jjm,ntra) - REAL S00(ntra) - REAL SM0 ! Just temporal variable -C -C work arrays -C - REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) - REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) - REAL TEMPTM ! Just temporal variable -c -C Special pour poles -c - REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn - REAL sns0(ntra),snsz(ntra),snsm - REAL s1v(llm),slatv(llm) - REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) - REAL cx1(llm,ntra), cxLAT(llm,ntra) - REAL cy1(llm,ntra), cyLAT(llm,ntra) - REAL z1(iim), zcos(iim), zsin(iim) - real smpn,smps,s0pn,s0ps - REAL SSUM - EXTERNAL SSUM -C - REAL sqi,sqf - LOGICAL LIMIT - - lon = iim ! rem : Il est possible qu'un pbl. arrive ici - lat = jjp1 ! a cause des dim. differentes entre les - niv=llm - -C -C the moments Fi are used as temporary storage for -C portions of the grid boxes in transit at the current level -C -C work arrays -C - - DO l = 1,llm - DO j = 1,jjm - DO i = 1,iip1 - vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l) - enddo - enddo - do i=1,iip1 - vgri(i,0,l) = 0. - vgri(i,jjp1,l) = 0. - enddo - enddo - - DO 1 L=1,NIV -C -C place limits on appropriate moments before transport -C (if flux-limiting is to be applied) -C - IF(.NOT.LIMIT) GO TO 11 -C - DO 10 JV=1,NTRA - DO 10 K=1,LAT - DO 100 I=1,LON - sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), - + ABS(sy(I,K,L,JV))),sy(I,K,L,JV)) - 100 CONTINUE - 10 CONTINUE -C - 11 CONTINUE -C -C le flux a travers le pole Nord est traite separement -C - SM0=0. - DO 20 JV=1,NTRA - S00(JV)=0. - 20 CONTINUE -C - DO 21 I=1,LON -C - IF(VGRI(I,0,L).LE.0.) THEN - FM(I,0)=-VGRI(I,0,L)*DTY - ALF(I,0)=FM(I,0)/SM(I,1,L) - SM(I,1,L)=SM(I,1,L)-FM(I,0) - SM0=SM0+FM(I,0) - ENDIF -C - ALFQ(I,0)=ALF(I,0)*ALF(I,0) - ALF1(I,0)=1.-ALF(I,0) - ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) -C - 21 CONTINUE -C - DO 22 JV=1,NTRA - DO 220 I=1,LON -C - IF(VGRI(I,0,L).LE.0.) THEN -C - F0(I,0,JV)=ALF(I,0)* - + ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) ) -C - S00(JV)=S00(JV)+F0(I,0,JV) - S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) - sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV) - sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV) - sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV) -C - ENDIF -C - 220 CONTINUE - 22 CONTINUE -C - DO 23 I=1,LON - IF(VGRI(I,0,L).GT.0.) THEN - FM(I,0)=VGRI(I,0,L)*DTY - ALF(I,0)=FM(I,0)/SM0 - ENDIF - 23 CONTINUE -C - DO 24 JV=1,NTRA - DO 240 I=1,LON - IF(VGRI(I,0,L).GT.0.) THEN - F0(I,0,JV)=ALF(I,0)*S00(JV) - ENDIF - 240 CONTINUE - 24 CONTINUE -C -C puts the temporary moments Fi into appropriate neighboring boxes -C - DO 25 I=1,LON -C - IF(VGRI(I,0,L).GT.0.) THEN - SM(I,1,L)=SM(I,1,L)+FM(I,0) - ALF(I,0)=FM(I,0)/SM(I,1,L) - ENDIF -C - ALF1(I,0)=1.-ALF(I,0) -C - 25 CONTINUE -C - DO 26 JV=1,NTRA - DO 260 I=1,LON -C - IF(VGRI(I,0,L).GT.0.) THEN -C - TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) - S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) - sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM -C - ENDIF -C - 260 CONTINUE - 26 CONTINUE -C -C calculate flux and moments between adjacent boxes -C 1- create temporary moments/masses for partial boxes in transit -C 2- reajusts moments remaining in the box -C -C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 -C - DO 30 K=1,LAT-1 - KP=K+1 - DO 300 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN - FM(I,K)=-VGRI(I,K,L)*DTY - ALF(I,K)=FM(I,K)/SM(I,KP,L) - SM(I,KP,L)=SM(I,KP,L)-FM(I,K) - ELSE - FM(I,K)=VGRI(I,K,L)*DTY - ALF(I,K)=FM(I,K)/SM(I,K,L) - SM(I,K,L)=SM(I,K,L)-FM(I,K) - ENDIF -C - ALFQ(I,K)=ALF(I,K)*ALF(I,K) - ALF1(I,K)=1.-ALF(I,K) - ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) -C - 300 CONTINUE - 30 CONTINUE -C - DO 31 JV=1,NTRA - DO 31 K=1,LAT-1 - KP=K+1 - DO 310 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN -C - F0(I,K,JV)=ALF (I,K)* - + ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) ) - FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV) - FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV) - FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV) -C - S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) - sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV) - sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV) - sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV) -C - ELSE -C - F0(I,K,JV)=ALF (I,K)* - + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) - FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV) - FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV) - FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV) -C - S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV) - sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) - sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV) - sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV) -C - ENDIF -C - 310 CONTINUE - 31 CONTINUE -C -C puts the temporary moments Fi into appropriate neighboring boxes -C - DO 32 K=1,LAT-1 - KP=K+1 - DO 320 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN - SM(I,K,L)=SM(I,K,L)+FM(I,K) - ALF(I,K)=FM(I,K)/SM(I,K,L) - ELSE - SM(I,KP,L)=SM(I,KP,L)+FM(I,K) - ALF(I,K)=FM(I,K)/SM(I,KP,L) - ENDIF -C - ALF1(I,K)=1.-ALF(I,K) -C - 320 CONTINUE - 32 CONTINUE -C - DO 33 JV=1,NTRA - DO 33 K=1,LAT-1 - KP=K+1 - DO 330 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN -C - TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) - S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) - sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV) - + +3.*TEMPTM - sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV) - sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV) -C - ELSE -C - TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) - S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) - sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV) - + +3.*TEMPTM - sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV) - sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV) -C - ENDIF -C - 330 CONTINUE - 33 CONTINUE -C -C traitement special pour le pole Sud (idem pole Nord) -C - K=LAT -C - SM0=0. - DO 40 JV=1,NTRA - S00(JV)=0. - 40 CONTINUE -C - DO 41 I=1,LON -C - IF(VGRI(I,K,L).GE.0.) THEN - FM(I,K)=VGRI(I,K,L)*DTY - ALF(I,K)=FM(I,K)/SM(I,K,L) - SM(I,K,L)=SM(I,K,L)-FM(I,K) - SM0=SM0+FM(I,K) - ENDIF -C - ALFQ(I,K)=ALF(I,K)*ALF(I,K) - ALF1(I,K)=1.-ALF(I,K) - ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) -C - 41 CONTINUE -C - DO 42 JV=1,NTRA - DO 420 I=1,LON -C - IF(VGRI(I,K,L).GE.0.) THEN - F0 (I,K,JV)=ALF(I,K)* - + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) - S00(JV)=S00(JV)+F0(I,K,JV) -C - S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) - sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) - sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV) - sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV) - ENDIF -C - 420 CONTINUE - 42 CONTINUE -C - DO 43 I=1,LON - IF(VGRI(I,K,L).LT.0.) THEN - FM(I,K)=-VGRI(I,K,L)*DTY - ALF(I,K)=FM(I,K)/SM0 - ENDIF - 43 CONTINUE -C - DO 44 JV=1,NTRA - DO 440 I=1,LON - IF(VGRI(I,K,L).LT.0.) THEN - F0(I,K,JV)=ALF(I,K)*S00(JV) - ENDIF - 440 CONTINUE - 44 CONTINUE -C -C puts the temporary moments Fi into appropriate neighboring boxes -C - DO 45 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN - SM(I,K,L)=SM(I,K,L)+FM(I,K) - ALF(I,K)=FM(I,K)/SM(I,K,L) - ENDIF -C - ALF1(I,K)=1.-ALF(I,K) -C - 45 CONTINUE -C - DO 46 JV=1,NTRA - DO 460 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN -C - TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) - S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) - sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM -C - ENDIF -C - 460 CONTINUE - 46 CONTINUE -C - 1 CONTINUE -C - RETURN - END - Index: LMDZ5/trunk/libf/dyn3dmem/advyp.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/advyp.F (revision 1944) +++ (revision ) @@ -1,653 +1,0 @@ -! -! $Header$ -! - SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ - . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) - IMPLICIT NONE -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C second-order moments (SOM) advection of tracer in Y direction C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Source : Pascal Simon ( Meteo, CNRM ) C -C Adaptation : A.A. (LGGE) C -C Derniere Modif : 19/10/95 LAST -C C -C sont les arguments d'entree pour le s-pg C -C C -C argument de sortie du s-pg C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Rem : Probleme aux poles il faut reecrire ce cas specifique -C Attention au sens de l'indexation -C -C parametres principaux du modele -C -C -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" -#include "comgeom.h" - -C Arguments : -C ---------- -C dty : frequence fictive d'appel du transport -C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 - - INTEGER lon,lat,niv - INTEGER i,j,jv,k,kp,l - INTEGER ntra -C PARAMETER (ntra = 1) - - REAL dty - REAL pbarv ( iip1,jjm, llm ) - -C moments: SM total mass in each grid box -C S0 mass of tracer in each grid box -C Si 1rst order moment in i direction -C - REAL SM(iip1,jjp1,llm) - + ,S0(iip1,jjp1,llm,ntra) - REAL SSX(iip1,jjp1,llm,ntra) - + ,SY(iip1,jjp1,llm,ntra) - + ,SZ(iip1,jjp1,llm,ntra) - + ,SSXX(iip1,jjp1,llm,ntra) - + ,SSXY(iip1,jjp1,llm,ntra) - + ,SSXZ(iip1,jjp1,llm,ntra) - + ,SYY(iip1,jjp1,llm,ntra) - + ,SYZ(iip1,jjp1,llm,ntra) - + ,SZZ(iip1,jjp1,llm,ntra) -C -C Local : -C ------- - -C mass fluxes across the boundaries (UGRI,VGRI,WGRI) -C mass fluxes in kg -C declaration : - - REAL VGRI(iip1,0:jjp1,llm) - -C Rem : UGRI et WGRI ne sont pas utilises dans -C cette subroutine ( advection en y uniquement ) -C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv -C -C the moments F are similarly defined and used as temporary -C storage for portions of the grid boxes in transit -C -C the moments Fij are used as temporary storage for -C portions of the grid boxes in transit at the current level -C -C work arrays -C -C - REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) - REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) - REAL FZ(iim,jjm,ntra) - REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra) - REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra) - REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra) - REAL S00(ntra) - REAL SM0 ! Just temporal variable -C -C work arrays -C - REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) - REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) - REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1) - REAL ALF4(iim,0:jjp1) - REAL TEMPTM ! Just temporal variable - REAL SLPMAX,S1MAX,S1NEW,S2NEW -c -C Special pour poles -c - REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn - REAL sns0(ntra),snsz(ntra),snsm - REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) - REAL cx1(llm,ntra), cxLAT(llm,ntra) - REAL cy1(llm,ntra), cyLAT(llm,ntra) - REAL z1(iim), zcos(iim), zsin(iim) - REAL SSUM - EXTERNAL SSUM -C - REAL sqi,sqf - LOGICAL LIMIT - - lon = iim ! rem : Il est possible qu'un pbl. arrive ici - lat = jjp1 ! a cause des dim. differentes entre les - niv = llm ! tab. S et VGRI - -c----------------------------------------------------------------- -C initialisations - - sbms = 0. - sfms = 0. - sfzs = 0. - sbmn = 0. - sfmn = 0. - sfzn = 0. - -c----------------------------------------------------------------- -C *** Test : diag de la qtite totale de traceur dans -C l'atmosphere avant l'advection en Y -c - sqi = 0. - sqf = 0. - - DO l = 1,llm - DO j = 1,jjp1 - DO i = 1,iim - sqi = sqi + S0(i,j,l,ntra) - END DO - END DO - END DO - PRINT*,'---------- DIAG DANS ADVY - ENTREE --------' - PRINT*,'sqi=',sqi - -c----------------------------------------------------------------- -C Interface : adaptation nouveau modele -C ------------------------------------- -C -C Conversion des flux de masses en kg -C-AA 20/10/94 le signe -1 est necessaire car indexation opposee - - DO 500 l = 1,llm - DO 500 j = 1,jjm - DO 500 i = 1,iip1 - vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l) - 500 CONTINUE - -CAA Initialisation de flux fictifs aux bords sup. des boites pol. - - DO l = 1,llm - DO i = 1,iip1 - vgri(i,0,l) = 0. - vgri(i,jjp1,l) = 0. - ENDDO - ENDDO -c -c----------------- START HERE ----------------------- -C boucle sur les niveaux -C - DO 1 L=1,NIV -C -C place limits on appropriate moments before transport -C (if flux-limiting is to be applied) -C - IF(.NOT.LIMIT) GO TO 11 -C - DO 10 JV=1,NTRA - DO 10 K=1,LAT - DO 100 I=1,LON - IF(S0(I,K,L,JV).GT.0.) THEN - SLPMAX=AMAX1(S0(I,K,L,JV),0.) - S1MAX=1.5*SLPMAX - S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV))) - S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , - + AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) ) - SY (I,K,L,JV)=S1NEW - SYY(I,K,L,JV)=S2NEW - SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV))) - SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) - ELSE - SY (I,K,L,JV)=0. - SYY(I,K,L,JV)=0. - SSXY(I,K,L,JV)=0. - SYZ(I,K,L,JV)=0. - ENDIF - 100 CONTINUE - 10 CONTINUE -C - 11 CONTINUE -C -C le flux a travers le pole Nord est traite separement -C - SM0=0. - DO 20 JV=1,NTRA - S00(JV)=0. - 20 CONTINUE -C - DO 21 I=1,LON -C - IF(VGRI(I,0,L).LE.0.) THEN - FM(I,0)=-VGRI(I,0,L)*DTY - ALF(I,0)=FM(I,0)/SM(I,1,L) - SM(I,1,L)=SM(I,1,L)-FM(I,0) - SM0=SM0+FM(I,0) - ENDIF -C - ALFQ(I,0)=ALF(I,0)*ALF(I,0) - ALF1(I,0)=1.-ALF(I,0) - ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) - ALF2(I,0)=ALF1(I,0)-ALF(I,0) - ALF3(I,0)=ALF(I,0)*ALFQ(I,0) - ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0) -C - 21 CONTINUE -c print*,'ADVYP 21' -C - DO 22 JV=1,NTRA - DO 220 I=1,LON -C - IF(VGRI(I,0,L).LE.0.) THEN -C - F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)* - + ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) ) -C - S00(JV)=S00(JV)+F0(I,0,JV) - S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) - SY (I,1,L,JV)=ALF1Q(I,0)* - + (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV)) - SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV) - SSX (I,1,L,JV)=ALF1 (I,0)* - + (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) ) - SZ (I,1,L,JV)=ALF1 (I,0)* - + (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) ) - SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV) - SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV) - SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV) - SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV) - SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV) -C - ENDIF -C - 220 CONTINUE - 22 CONTINUE -C - DO 23 I=1,LON - IF(VGRI(I,0,L).GT.0.) THEN - FM(I,0)=VGRI(I,0,L)*DTY - ALF(I,0)=FM(I,0)/SM0 - ENDIF - 23 CONTINUE -C - DO 24 JV=1,NTRA - DO 240 I=1,LON - IF(VGRI(I,0,L).GT.0.) THEN - F0(I,0,JV)=ALF(I,0)*S00(JV) - ENDIF - 240 CONTINUE - 24 CONTINUE -C -C puts the temporary moments Fi into appropriate neighboring boxes -C -c print*,'av ADVYP 25' - DO 25 I=1,LON -C - IF(VGRI(I,0,L).GT.0.) THEN - SM(I,1,L)=SM(I,1,L)+FM(I,0) - ALF(I,0)=FM(I,0)/SM(I,1,L) - ENDIF -C - ALFQ(I,0)=ALF(I,0)*ALF(I,0) - ALF1(I,0)=1.-ALF(I,0) - ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) - ALF2(I,0)=ALF1(I,0)-ALF(I,0) - ALF3(I,0)=ALF1(I,0)*ALF(I,0) -C - 25 CONTINUE -c print*,'av ADVYP 25' -C - DO 26 JV=1,NTRA - DO 260 I=1,LON -C - IF(VGRI(I,0,L).GT.0.) THEN -C - TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) - S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) - SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV) - + +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM ) - SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM - SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV) - SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV) -C - ENDIF -C - 260 CONTINUE - 26 CONTINUE -C -C calculate flux and moments between adjacent boxes -C 1- create temporary moments/masses for partial boxes in transit -C 2- reajusts moments remaining in the box -C -C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 -C -c print*,'av ADVYP 30' - DO 30 K=1,LAT-1 - KP=K+1 - DO 300 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN - FM(I,K)=-VGRI(I,K,L)*DTY - ALF(I,K)=FM(I,K)/SM(I,KP,L) - SM(I,KP,L)=SM(I,KP,L)-FM(I,K) - ELSE - FM(I,K)=VGRI(I,K,L)*DTY - ALF(I,K)=FM(I,K)/SM(I,K,L) - SM(I,K,L)=SM(I,K,L)-FM(I,K) - ENDIF -C - ALFQ(I,K)=ALF(I,K)*ALF(I,K) - ALF1(I,K)=1.-ALF(I,K) - ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) - ALF2(I,K)=ALF1(I,K)-ALF(I,K) - ALF3(I,K)=ALF(I,K)*ALFQ(I,K) - ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) -C - 300 CONTINUE - 30 CONTINUE -c print*,'ap ADVYP 30' -C - DO 31 JV=1,NTRA - DO 31 K=1,LAT-1 - KP=K+1 - DO 310 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN -C - F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)* - + ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) ) - FY (I,K,JV)=ALFQ(I,K)* - + (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV)) - FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV) - FX (I,K,JV)=ALF (I,K)* - + (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV)) - FZ (I,K,JV)=ALF (I,K)* - + (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV)) - FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV) - FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV) - FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV) - FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV) - FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV) -C - S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) - SY (I,KP,L,JV)=ALF1Q(I,K)* - + (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV)) - SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV) - SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV) - SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV) - SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV) - SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV) - SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV) - SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV) - SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV) -C - ELSE -C - F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* - + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) - FY (I,K,JV)=ALFQ(I,K)* - + (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV)) - FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV) - FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV)) - FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV)) - FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV) - FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV) - FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV) - FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV) - FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV) -C - S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) - SY (I,K,L,JV)=ALF1Q(I,K)* - + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) - SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV) - SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV) - SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV) - SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV) - SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV) - SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV) - SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) - SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) -C - ENDIF -C - 310 CONTINUE - 31 CONTINUE -c print*,'ap ADVYP 31' -C -C puts the temporary moments Fi into appropriate neighboring boxes -C - DO 32 K=1,LAT-1 - KP=K+1 - DO 320 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN - SM(I,K,L)=SM(I,K,L)+FM(I,K) - ALF(I,K)=FM(I,K)/SM(I,K,L) - ELSE - SM(I,KP,L)=SM(I,KP,L)+FM(I,K) - ALF(I,K)=FM(I,K)/SM(I,KP,L) - ENDIF -C - ALFQ(I,K)=ALF(I,K)*ALF(I,K) - ALF1(I,K)=1.-ALF(I,K) - ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) - ALF2(I,K)=ALF1(I,K)-ALF(I,K) - ALF3(I,K)=ALF1(I,K)*ALF(I,K) -C - 320 CONTINUE - 32 CONTINUE -c print*,'ap ADVYP 32' -C - DO 33 JV=1,NTRA - DO 33 K=1,LAT-1 - KP=K+1 - DO 330 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN -C - TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) - S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) - SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV) - + +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM ) - SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV) - + +3.*TEMPTM - SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV) - + +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV)) - SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV) - + +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV)) - SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV) - SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV) - SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV) - SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV) - SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV) -C - ELSE -C - TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) - S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) - SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV) - + +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM ) - SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV) - + +3.*TEMPTM - SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV) - + +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV)) - SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV) - + +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV)) - SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV) - SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV) - SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV) - SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV) - SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV) -C - ENDIF -C - 330 CONTINUE - 33 CONTINUE -c print*,'ap ADVYP 33' -C -C traitement special pour le pole Sud (idem pole Nord) -C - K=LAT -C - SM0=0. - DO 40 JV=1,NTRA - S00(JV)=0. - 40 CONTINUE -C - DO 41 I=1,LON -C - IF(VGRI(I,K,L).GE.0.) THEN - FM(I,K)=VGRI(I,K,L)*DTY - ALF(I,K)=FM(I,K)/SM(I,K,L) - SM(I,K,L)=SM(I,K,L)-FM(I,K) - SM0=SM0+FM(I,K) - ENDIF -C - ALFQ(I,K)=ALF(I,K)*ALF(I,K) - ALF1(I,K)=1.-ALF(I,K) - ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) - ALF2(I,K)=ALF1(I,K)-ALF(I,K) - ALF3(I,K)=ALF(I,K)*ALFQ(I,K) - ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) -C - 41 CONTINUE -c print*,'ap ADVYP 41' -C - DO 42 JV=1,NTRA - DO 420 I=1,LON -C - IF(VGRI(I,K,L).GE.0.) THEN - F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* - + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) - S00(JV)=S00(JV)+F0(I,K,JV) -C - S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) - SY (I,K,L,JV)=ALF1Q(I,K)* - + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) - SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV) - SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV)) - SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV)) - SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV) - SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV) - SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV) - SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) - SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) - ENDIF -C - 420 CONTINUE - 42 CONTINUE -c print*,'ap ADVYP 42' -C - DO 43 I=1,LON - IF(VGRI(I,K,L).LT.0.) THEN - FM(I,K)=-VGRI(I,K,L)*DTY - ALF(I,K)=FM(I,K)/SM0 - ENDIF - 43 CONTINUE -c print*,'ap ADVYP 43' -C - DO 44 JV=1,NTRA - DO 440 I=1,LON - IF(VGRI(I,K,L).LT.0.) THEN - F0(I,K,JV)=ALF(I,K)*S00(JV) - ENDIF - 440 CONTINUE - 44 CONTINUE -C -C puts the temporary moments Fi into appropriate neighboring boxes -C - DO 45 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN - SM(I,K,L)=SM(I,K,L)+FM(I,K) - ALF(I,K)=FM(I,K)/SM(I,K,L) - ENDIF -C - ALFQ(I,K)=ALF(I,K)*ALF(I,K) - ALF1(I,K)=1.-ALF(I,K) - ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) - ALF2(I,K)=ALF1(I,K)-ALF(I,K) - ALF3(I,K)=ALF1(I,K)*ALF(I,K) -C - 45 CONTINUE -c print*,'ap ADVYP 45' -C - DO 46 JV=1,NTRA - DO 460 I=1,LON -C - IF(VGRI(I,K,L).LT.0.) THEN -C - TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) - S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) - SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV) - + +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM ) - SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM - SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV) - SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV) -C - ENDIF -C - 460 CONTINUE - 46 CONTINUE -c print*,'ap ADVYP 46' -C - 1 CONTINUE - -c-------------------------------------------------- -C bouclage cyclique horizontal . - - DO l = 1,llm - DO jv = 1,ntra - DO j = 1,jjp1 - SM(iip1,j,l) = SM(1,j,l) - S0(iip1,j,l,jv) = S0(1,j,l,jv) - SSX(iip1,j,l,jv) = SSX(1,j,l,jv) - SY(iip1,j,l,jv) = SY(1,j,l,jv) - SZ(iip1,j,l,jv) = SZ(1,j,l,jv) - END DO - END DO - END DO - -c ------------------------------------------------------------------- -C *** Test negativite: - -c DO jv = 1,ntra -c DO l = 1,llm -c DO j = 1,jjp1 -c DO i = 1,iip1 -c IF (s0( i,j,l,jv ).lt.0.) THEN -c PRINT*, '------ S0 < 0 en FIN ADVYP ---' -c PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv) -cc STOP -c ENDIF -c ENDDO -c ENDDO -c ENDDO -c ENDDO - - -c ------------------------------------------------------------------- -C *** Test : diag de la qtite totale de traceur dans -C l'atmosphere avant l'advection en Y - - DO l = 1,llm - DO j = 1,jjp1 - DO i = 1,iim - sqf = sqf + S0(i,j,l,ntra) - END DO - END DO - END DO - PRINT*,'---------- DIAG DANS ADVY - SORTIE --------' - PRINT*,'sqf=',sqf -c print*,'ap ADVYP fin' - -c----------------------------------------------------------------- -C - RETURN - END - - - - - - - - - - - - Index: LMDZ5/trunk/libf/dyn3dmem/advzp.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/advzp.F (revision 1944) +++ (revision ) @@ -1,378 +1,0 @@ -! -! $Header$ -! - SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ - . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) - - IMPLICIT NONE - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C second-order moments (SOM) advection of tracer in Z direction C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Source : Pascal Simon ( Meteo, CNRM ) C -C Adaptation : A.A. (LGGE) C -C Derniere Modif : 19/11/95 LAST C -C C -C sont les arguments d'entree pour le s-pg C -C C -C argument de sortie du s-pg C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C Rem : Probleme aux poles il faut reecrire ce cas specifique -C Attention au sens de l'indexation -C - -C -C parametres principaux du modele -C -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" -#include "comgeom.h" -C -C Arguments : -C ---------- -C dty : frequence fictive d'appel du transport -C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 -c - INTEGER lon,lat,niv - INTEGER i,j,jv,k,kp,l,lp - INTEGER ntra -c PARAMETER (ntra = 1) -c - REAL dtz - REAL w ( iip1,jjp1,llm ) -c -C moments: SM total mass in each grid box -C S0 mass of tracer in each grid box -C Si 1rst order moment in i direction -C - REAL SM(iip1,jjp1,llm) - + ,S0(iip1,jjp1,llm,ntra) - REAL SSX(iip1,jjp1,llm,ntra) - + ,SY(iip1,jjp1,llm,ntra) - + ,SZ(iip1,jjp1,llm,ntra) - + ,SSXX(iip1,jjp1,llm,ntra) - + ,SSXY(iip1,jjp1,llm,ntra) - + ,SSXZ(iip1,jjp1,llm,ntra) - + ,SYY(iip1,jjp1,llm,ntra) - + ,SYZ(iip1,jjp1,llm,ntra) - + ,SZZ(iip1,jjp1,llm,ntra) -C -C Local : -C ------- -C -C mass fluxes across the boundaries (UGRI,VGRI,WGRI) -C mass fluxes in kg -C declaration : -C - REAL WGRI(iip1,jjp1,0:llm) - -C Rem : UGRI et VGRI ne sont pas utilises dans -C cette subroutine ( advection en z uniquement ) -C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv -C attention a celui de WGRI -C -C the moments F are similarly defined and used as temporary -C storage for portions of the grid boxes in transit -C -C the moments Fij are used as temporary storage for -C portions of the grid boxes in transit at the current level -C -C work arrays -C -C - REAL F0(iim,llm,ntra),FM(iim,llm) - REAL FX(iim,llm,ntra),FY(iim,llm,ntra) - REAL FZ(iim,llm,ntra) - REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra) - REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra) - REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra) - REAL S00(ntra) - REAL SM0 ! Just temporal variable -C -C work arrays -C - REAL ALF(iim),ALF1(iim) - REAL ALFQ(iim),ALF1Q(iim) - REAL ALF2(iim),ALF3(iim) - REAL ALF4(iim) - REAL TEMPTM ! Just temporal variable - REAL SLPMAX,S1MAX,S1NEW,S2NEW -c - REAL sqi,sqf - LOGICAL LIMIT - - lon = iim ! rem : Il est possible qu'un pbl. arrive ici - lat = jjp1 ! a cause des dim. differentes entre les - niv = llm ! tab. S et VGRI - -c----------------------------------------------------------------- -C *** Test : diag de la qtite totale de traceur dans -C l'atmosphere avant l'advection en Y -c - sqi = 0. - sqf = 0. -c - DO l = 1,llm - DO j = 1,jjp1 - DO i = 1,iim - sqi = sqi + S0(i,j,l,ntra) - END DO - END DO - END DO - PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------' - PRINT*,'sqi=',sqi - -c----------------------------------------------------------------- -C Interface : adaptation nouveau modele -C ------------------------------------- -C -C Conversion des flux de masses en kg - - DO 500 l = 1,llm - DO 500 j = 1,jjp1 - DO 500 i = 1,iip1 - wgri (i,j,llm+1-l) = w (i,j,l) - 500 CONTINUE - do j=1,jjp1 - do i=1,iip1 - wgri(i,j,0)=0. - enddo - enddo -c -cAA rem : Je ne suis pas sur du signe -cAA Je ne suis pas sur pour le 0:llm -c -c----------------------------------------------------------------- -C---------------------- START HERE ------------------------------- -C -C boucle sur les latitudes -C - DO 1 K=1,LAT -C -C place limits on appropriate moments before transport -C (if flux-limiting is to be applied) -C - IF(.NOT.LIMIT) GO TO 101 -C - DO 10 JV=1,NTRA - DO 10 L=1,NIV - DO 100 I=1,LON - IF(S0(I,K,L,JV).GT.0.) THEN - SLPMAX=S0(I,K,L,JV) - S1MAX =1.5*SLPMAX - S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV))) - S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , - + AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) ) - SZ (I,K,L,JV)=S1NEW - SZZ(I,K,L,JV)=S2NEW - SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV))) - SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) - ELSE - SZ (I,K,L,JV)=0. - SZZ(I,K,L,JV)=0. - SSXZ(I,K,L,JV)=0. - SYZ(I,K,L,JV)=0. - ENDIF - 100 CONTINUE - 10 CONTINUE -C - 101 CONTINUE -C -C boucle sur les niveaux intercouches de 1 a NIV-1 -C (flux nul au sommet L=0 et a la base L=NIV) -C -C calculate flux and moments between adjacent boxes -C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0) -C 1- create temporary moments/masses for partial boxes in transit -C 2- reajusts moments remaining in the box -C - DO 11 L=1,NIV-1 - LP=L+1 -C - DO 110 I=1,LON -C - IF(WGRI(I,K,L).LT.0.) THEN - FM(I,L)=-WGRI(I,K,L)*DTZ - ALF(I)=FM(I,L)/SM(I,K,LP) - SM(I,K,LP)=SM(I,K,LP)-FM(I,L) - ELSE - FM(I,L)=WGRI(I,K,L)*DTZ - ALF(I)=FM(I,L)/SM(I,K,L) - SM(I,K,L)=SM(I,K,L)-FM(I,L) - ENDIF -C - ALFQ (I)=ALF(I)*ALF(I) - ALF1 (I)=1.-ALF(I) - ALF1Q(I)=ALF1(I)*ALF1(I) - ALF2 (I)=ALF1(I)-ALF(I) - ALF3 (I)=ALF(I)*ALFQ(I) - ALF4 (I)=ALF1(I)*ALF1Q(I) -C - 110 CONTINUE -C - DO 111 JV=1,NTRA - DO 1110 I=1,LON -C - IF(WGRI(I,K,L).LT.0.) THEN -C - F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)* - + ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) ) - FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV)) - FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV) - FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV) - FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV) - FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV)) - FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV)) - FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV) - FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV) - FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV) -C - S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV) - SZ (I,K,LP,JV)=ALF1Q(I) - + *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV)) - SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV) - SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV) - SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV) - SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV) - SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV) - SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV) - SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV) - SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV) -C - ELSE -C - F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV) - + +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) ) - FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV)) - FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV) - FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV) - FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV) - FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV)) - FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV)) - FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV) - FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV) - FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV) -C - S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV) - SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV)) - SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV) - SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV) - SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV) - SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV) - SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV) - SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV) - SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV) - SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV) -C - ENDIF -C - 1110 CONTINUE - 111 CONTINUE -C - 11 CONTINUE -C -C puts the temporary moments Fi into appropriate neighboring boxes -C - DO 12 L=1,NIV-1 - LP=L+1 -C - DO 120 I=1,LON -C - IF(WGRI(I,K,L).LT.0.) THEN - SM(I,K,L)=SM(I,K,L)+FM(I,L) - ALF(I)=FM(I,L)/SM(I,K,L) - ELSE - SM(I,K,LP)=SM(I,K,LP)+FM(I,L) - ALF(I)=FM(I,L)/SM(I,K,LP) - ENDIF -C - ALF1(I)=1.-ALF(I) - ALFQ(I)=ALF(I)*ALF(I) - ALF1Q(I)=ALF1(I)*ALF1(I) - ALF2(I)=ALF(I)*ALF1(I) - ALF3(I)=ALF1(I)-ALF(I) -C - 120 CONTINUE -C - DO 121 JV=1,NTRA - DO 1210 I=1,LON -C - IF(WGRI(I,K,L).LT.0.) THEN -C - TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV) - S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV) - SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV) - + +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM ) - SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV) - + +3.*TEMPTM - SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV) - + +3.*(ALF1(I)*FX (I,L,JV)-ALF (I)*SSX (I,K,L,JV)) - SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV) - + +3.*(ALF1(I)*FY (I,L,JV)-ALF (I)*SY (I,K,L,JV)) - SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV) - SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV) - SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV) - SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV) - SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV) -C - ELSE -C - TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV) - S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV) - SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV) - + +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM ) - SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV) - + +3.*TEMPTM - SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV) - + +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV)) - SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV) - + +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV)) - SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV) - SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV) - SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV) - SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV) - SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV) -C - ENDIF -C - 1210 CONTINUE - 121 CONTINUE -C - 12 CONTINUE -C -C fin de la boucle principale sur les latitudes -C - 1 CONTINUE -C - DO l = 1,llm - DO j = 1,jjp1 - SM(iip1,j,l) = SM(1,j,l) - S0(iip1,j,l,ntra) = S0(1,j,l,ntra) - SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) - SY(iip1,j,l,ntra) = SY(1,j,l,ntra) - SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) - ENDDO - ENDDO -c C------------------------------------------------------------- -C *** Test : diag de la qqtite totale de tarceur -C dans l'atmosphere avant l'advection en z - DO l = 1,llm - DO j = 1,jjp1 - DO i = 1,iim - sqf = sqf + S0(i,j,l,ntra) - ENDDO - ENDDO - ENDDO - PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' - PRINT*,'sqf=', sqf - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/bernoui.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/bernoui.F (revision 1944) +++ (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: LMDZ5/trunk/libf/dyn3dmem/caldyn0.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/caldyn0.F (revision 1944) +++ (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: LMDZ5/trunk/libf/dyn3dmem/clesph0.h =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/clesph0.h (revision 1944) +++ (revision ) @@ -1,11 +1,0 @@ -! -! $Header$ -! -c..include clesph0.h -c - COMMON/clesph0/cycle_diurne, soil_model,new_oliq, ok_orodr , - , ok_orolf ,ok_limitvrai, nbapp_rad, iflag_con -c - LOGICAL cycle_diurne,soil_model,ok_orodr,ok_orolf,new_oliq - LOGICAL ok_limitvrai - INTEGER nbapp_rad, iflag_con Index: LMDZ5/trunk/libf/dyn3dmem/coefpoly.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/coefpoly.F (revision 1944) +++ (revision ) @@ -1,40 +1,0 @@ -! -! $Header$ -! - SUBROUTINE coefpoly ( Xf1, Xf2, Xprim1, Xprim2, xtild1,xtild2 , - , a0,a1,a2,a3 ) - IMPLICIT NONE -c -c ... Auteur : P. Le Van ... -c -c -c Calcul des coefficients a0, a1, a2, a3 du polynome de degre 3 qui -c satisfait aux 4 equations suivantes : - -c a0 + a1*xtild1 + a2*xtild1*xtild1 + a3*xtild1*xtild1*xtild1 = Xf1 -c a0 + a1*xtild2 + a2*xtild2*xtild2 + a3*xtild2*xtild2*xtild2 = Xf2 -c a1 + 2.*a2*xtild1 + 3.*a3*xtild1*xtild1 = Xprim1 -c a1 + 2.*a2*xtild2 + 3.*a3*xtild2*xtild2 = Xprim2 - -c On en revient a resoudre un systeme de 4 equat.a 4 inconnues a0,a1,a2,a3 - - REAL(KIND=8) Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi - REAL(KIND=8) Xfout, Xprim - REAL(KIND=8) a1,a2,a3,a0, xtil1car, xtil2car,derr,x1x2car - - xtil1car = xtild1 * xtild1 - xtil2car = xtild2 * xtild2 - - derr= 2. *(Xf2-Xf1)/( xtild1-xtild2) - - x1x2car = ( xtild1-xtild2)*(xtild1-xtild2) - - a3 = (derr + Xprim1+Xprim2 )/x1x2car - a2 = ( Xprim1 - Xprim2 + 3.* a3 * ( xtil2car-xtil1car ) ) / - / ( 2.* ( xtild1 - xtild2 ) ) - - a1 = Xprim1 -3.* a3 * xtil1car -2.* a2 * xtild1 - a0 = Xf1 - a3 * xtild1* xtil1car -a2 * xtil1car - a1 *xtild1 - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/com_io_dyn_mod.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/com_io_dyn_mod.F90 (revision 1944) +++ (revision ) @@ -1,31 +1,0 @@ -! -! $Id $ -! -module com_io_dyn_mod - - implicit none - -! Names of various files for outputs (in the dynamics) - ! to store instantaneous values: - character(len=18),parameter :: dynhist_file="dyn_hist.nc" ! on scalar grid - character(len=18),parameter :: dynhistv_file="dyn_histv.nc" ! on v grid - character(len=18),parameter :: dynhistu_file="dyn_histu.nc" ! on u grid - - ! to store averaged values: - character(len=18),parameter :: dynhistave_file="dyn_hist_ave.nc" - character(len=18),parameter :: dynhistvave_file="dyn_histv_ave.nc" - character(len=18),parameter :: dynhistuave_file="dyn_histu_ave.nc" - -! Ids of various files for outputs (in the dynamics) - - ! instantaneous (these are set by inithist.F) - integer :: histid - integer :: histvid - integer :: histuid - - ! averages (these are set by initdynav.F) - integer :: histaveid - integer :: histvaveid - integer :: histuaveid - -end module com_io_dyn_mod Index: LMDZ5/trunk/libf/dyn3dmem/comdissip.h =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/comdissip.h (revision 1944) +++ (revision ) @@ -1,15 +1,0 @@ -! -! $Header$ -! -!----------------------------------------------------------------------- -! INCLUDE comdissip.h - - COMMON/comdissip/ & - & niterdis,coefdis,tetavel,tetatemp,gamdissip - - - INTEGER niterdis - - REAL tetavel,tetatemp,coefdis,gamdissip - -!----------------------------------------------------------------------- Index: LMDZ5/trunk/libf/dyn3dmem/comgeom.h =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/comgeom.h (revision 1944) +++ (revision ) @@ -1,33 +1,0 @@ -! -! $Header$ -! -!CDK comgeom - COMMON/comgeom/ & - & cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm), & - & aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1), & - & airev(ip1jm),unsaire(ip1jmp1),apoln,apols, & - & unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm), & - & aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1), & - & aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1), & - & alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1), & - & alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1), & - & fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm), & - & rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm), & - & cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm), & - & cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1), & - & cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1), & - & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2, & - & unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm), & - & aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1) - -! - REAL & - & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln ,& - & apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,& - & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,& - & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 ,& - & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2& - & ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam ,& - & aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu& - & , xprimv -! Index: LMDZ5/trunk/libf/dyn3dmem/comgeom2.h =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/comgeom2.h (revision 1944) +++ (revision ) @@ -1,33 +1,0 @@ -! -! $Header$ -! -!CDK comgeom2 - COMMON/comgeom/ & - & cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm) , & - & aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1) , & - & airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols , & - & unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm) , & - & aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1) , & - & aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1) , & - & alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1) , & - & alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1) , & - & fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm), & - & rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm) , & - & cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1) , & - & cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1), & - & cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) , & - & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2 , & - & unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1) , & - & unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm) & - & , xprimu(iip1),xprimv(iip1) - - - REAL & - & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire & - & ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4 , & - & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 , & - & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 , & - & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1 , & - & unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2 , & - & unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu , & - & cusurcvu,xprimu,xprimv Index: LMDZ5/trunk/libf/dyn3dmem/conf_dat2d.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/conf_dat2d.F (revision 1944) +++ (revision ) @@ -1,221 +1,0 @@ -! -! $Header$ -! -C -C - SUBROUTINE conf_dat2d( title,lons,lats,xd,yd,xf,yf,champd , - , interbar ) -c -c Auteur : P. Le Van - -c Ce s-pr. configure le champ de donnees 2D 'champd' de telle facon que -c qu'on ait - pi a pi en longitude -c et qu'on ait pi/2. a - pi/2. en latitude -c -c xd et yd sont les longitudes et latitudes initiales -c xf et yf sont les longitudes et latitudes en sortie , eventuellement -c modifiees pour etre configurees comme ci-dessus . - - IMPLICIT NONE - -c *** Arguments en entree *** - INTEGER lons,lats - CHARACTER*25 title - REAL xd(lons),yd(lats) - LOGICAL interbar -c -c *** Arguments en sortie *** - REAL xf(lons),yf(lats) -c -c *** Arguments en entree et sortie *** - REAL champd(lons,lats) - -c *** Variables locales *** -c - REAL pi,pis2,depi - LOGICAL radianlon, invlon ,radianlat, invlat, alloc - REAL rlatmin,rlatmax,oldxd1 - INTEGER i,j,ip180,ind - - REAL, ALLOCATABLE :: xtemp(:) - REAL, ALLOCATABLE :: ytemp(:) - REAL, ALLOCATABLE :: champf(:,:) - -c -c WRITE(6,*) ' conf_dat2d pour la variable ', title - - ALLOCATE( xtemp(lons) ) - ALLOCATE( ytemp(lats) ) - ALLOCATE( champf(lons,lats) ) - - DO i = 1, lons - xtemp(i) = xd(i) - ENDDO - DO j = 1, lats - ytemp(j) = yd(j) - ENDDO - - pi = 2. * ASIN(1.) - pis2 = pi/2. - depi = 2. * pi - - radianlon = .FALSE. - IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN - radianlon = .TRUE. - invlon = .FALSE. - ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN - radianlon = .TRUE. - invlon = .TRUE. - ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN - radianlon = .FALSE. - invlon = .FALSE. - ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN - radianlon = .FALSE. - invlon = .TRUE. - ELSE - WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' - , , title - ENDIF - - invlat = .FALSE. - - IF( ytemp(1).LT.ytemp(lats) ) THEN - invlat = .TRUE. - ENDIF - - rlatmin = MIN( ytemp(1), ytemp(lats) ) - rlatmax = MAX( ytemp(1), ytemp(lats) ) - - IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN - radianlat = .TRUE. - ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN - radianlat = .FALSE. - ELSE - WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' - , , title - ENDIF - - IF( .NOT. radianlon ) THEN - DO i = 1, lons - xtemp(i) = xtemp(i) * pi/180. - ENDDO - ENDIF - - IF( .NOT. radianlat ) THEN - DO j = 1, lats - ytemp(j) = ytemp(j) * pi/180. - ENDDO - ENDIF - - - IF ( invlon ) THEN - - DO j = 1, lats - DO i = 1,lons - champf(i,j) = champd(i,j) - ENDDO - ENDDO - - DO i = 1 ,lons - xf(i) = xtemp(i) - ENDDO -c -c *** On tourne les longit. pour avoir - pi a + pi **** -c - DO i=1,lons - IF( xf(i).GT. pi ) THEN - GO TO 88 - ENDIF - ENDDO - -88 CONTINUE -c - ip180 = i - - DO i = 1,lons - IF (xf(i).GT. pi) THEN - xf(i) = xf(i) - depi - ENDIF - ENDDO - - DO i= ip180,lons - ind = i-ip180 +1 - xtemp(ind) = xf(i) - ENDDO - - DO i= ind +1,lons - xtemp(i) = xf(i-ind) - ENDDO - -c ..... on tourne les longitudes pour champf .... -c - DO j = 1,lats - - DO i = ip180,lons - ind = i-ip180 +1 - champd (ind,j) = champf (i,j) - ENDDO - - DO i= ind +1,lons - champd (i,j) = champf (i-ind,j) - ENDDO - - ENDDO - - - ENDIF -c -c ***** fin de IF(invlon) **** - - IF ( invlat ) THEN - - DO j = 1,lats - yf(j) = ytemp(j) - ENDDO - - DO j = 1, lats - DO i = 1,lons - champf(i,j) = champd(i,j) - ENDDO - ENDDO - - DO j = 1, lats - ytemp( lats-j+1 ) = yf(j) - DO i = 1, lons - champd (i,lats-j+1) = champf (i,j) - ENDDO - ENDDO - - - ENDIF - -c ***** fin de IF(invlat) **** - -c - IF( interbar ) THEN - oldxd1 = xtemp(1) - DO i = 1, lons -1 - xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) - ENDDO - xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) - - DO j = 1, lats -1 - ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) - ENDDO - - ENDIF -c - DEALLOCATE(champf) - - DO i = 1, lons - xf(i) = xtemp(i) - ENDDO - DO j = 1, lats - yf(j) = ytemp(j) - ENDDO - - deallocate(xtemp) - deallocate(ytemp) - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/conf_dat3d.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/conf_dat3d.F (revision 1944) +++ (revision ) @@ -1,296 +1,0 @@ -! -! $Header$ -! -C -C - SUBROUTINE conf_dat3d( title, lons,lats,levs,xd,yd,zd,xf,yf,zf, - , champd , interbar ) -c -c Auteur : P. Le Van -c -c Ce s-pr. configure le champ de donnees 3D 'champd' de telle facon -c qu'on ait - pi a pi en longitude -c qu'on ait pi/2. a - pi/2. en latitude -c et qu'on ait les niveaux verticaux variant du sol vers le ht de l'atmos. -c ( en Pascals ) . -c -c xd et yd sont les longitudes et latitudes initiales -c zd les pressions initiales -c -c xf et yf sont les longitudes et latitudes en sortie , eventuellement -c modifiees pour etre configurees comme ci-dessus . -c zf les pressions en sortie -c -c champd en meme temps le champ initial et final -c -c interbar = .TRUE. si on appelle l'interpo. barycentrique inter_barxy -c sinon , l'interpolation grille_m ( grid_atob ) . -c - - IMPLICIT NONE - -c *** Arguments en entree *** - CHARACTER*(*) :: title - INTEGER lons, lats, levs - REAL xd(lons), yd(lats), zd(levs) - LOGICAL interbar -c -c *** Arguments en sortie *** - REAL xf(lons), yf(lats), zf(levs) - -c *** Arguments en entree et sortie *** - REAL champd(lons,lats,levs) - -c *** Variables locales *** -c - REAL pi,pis2,depi,presmax - LOGICAL radianlon, invlon ,radianlat, invlat, invlev, alloc - REAL rlatmin,rlatmax,oldxd1 - INTEGER i,j,ip180,ind,l - - REAL, ALLOCATABLE :: xtemp(:) - REAL, ALLOCATABLE :: ytemp(:) - REAL, ALLOCATABLE :: ztemp(:) - REAL, ALLOCATABLE :: champf(:,:,:) - - -c WRITE(6,*) ' Conf_dat3d pour ',title - - ALLOCATE(xtemp(lons)) - ALLOCATE(ytemp(lats)) - ALLOCATE(ztemp(levs)) - - DO i = 1, lons - xtemp(i) = xd(i) - ENDDO - DO j = 1, lats - ytemp(j) = yd(j) - ENDDO - DO l = 1, levs - ztemp(l) = zd(l) - ENDDO - - pi = 2. * ASIN(1.) - pis2 = pi/2. - depi = 2. * pi - - IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN - radianlon = .TRUE. - invlon = .FALSE. - ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN - radianlon = .TRUE. - invlon = .TRUE. - ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN - radianlon = .FALSE. - invlon = .FALSE. - ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN - radianlon = .FALSE. - invlon = .TRUE. - ELSE - WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' - , , title - ENDIF - - invlat = .FALSE. - - IF( ytemp(1).LT.ytemp(lats) ) THEN - invlat = .TRUE. - ENDIF - - rlatmin = MIN( ytemp(1), ytemp(lats) ) - rlatmax = MAX( ytemp(1), ytemp(lats) ) - - IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN - radianlat = .TRUE. - ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN - radianlat = .FALSE. - ELSE - WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' - , , title - ENDIF - - IF( .NOT. radianlon ) THEN - DO i = 1, lons - xtemp(i) = xtemp(i) * pi/180. - ENDDO - ENDIF - - IF( .NOT. radianlat ) THEN - DO j = 1, lats - ytemp(j) = ytemp(j) * pi/180. - ENDDO - ENDIF - - - alloc =.FALSE. - - IF ( invlon ) THEN - - ALLOCATE(champf(lons,lats,levs)) - alloc = .TRUE. - - DO i = 1 ,lons - xf(i) = xtemp(i) - ENDDO - - DO l = 1, levs - DO j = 1, lats - DO i= 1, lons - champf (i,j,l) = champd (i,j,l) - ENDDO - ENDDO - ENDDO -c -c *** On tourne les longit. pour avoir - pi a + pi **** -c - DO i=1,lons - IF( xf(i).GT. pi ) THEN - GO TO 88 - ENDIF - ENDDO - -88 CONTINUE -c - ip180 = i - - DO i = 1,lons - IF (xf(i).GT. pi) THEN - xf(i) = xf(i) - depi - ENDIF - ENDDO - - DO i= ip180,lons - ind = i-ip180 +1 - xtemp(ind) = xf(i) - ENDDO - - DO i= ind +1,lons - xtemp(i) = xf(i-ind) - ENDDO - -c ..... on tourne les longitudes pour champf .... -c - DO l = 1,levs - DO j = 1,lats - DO i = ip180,lons - ind = i-ip180 +1 - champd (ind,j,l) = champf (i,j,l) - ENDDO - - DO i= ind +1,lons - champd (i,j,l) = champf (i-ind,j,l) - ENDDO - ENDDO - ENDDO - - ENDIF -c -c ***** fin de IF(invlon) **** - - IF ( invlat ) THEN - - IF(.NOT.alloc) THEN - ALLOCATE(champf(lons,lats,levs)) - alloc = .TRUE. - ENDIF - - DO j = 1, lats - yf(j) = ytemp(j) - ENDDO - - DO l = 1,levs - DO j = 1, lats - DO i = 1,lons - champf(i,j,l) = champd(i,j,l) - ENDDO - ENDDO - - DO j = 1, lats - ytemp( lats-j+1 ) = yf(j) - DO i = 1, lons - champd (i,lats-j+1,l) = champf (i,j,l) - ENDDO - ENDDO - ENDDO - - - ENDIF - -c ***** fin de IF(invlat) **** -c -c - IF( interbar ) THEN - oldxd1 = xtemp(1) - DO i = 1, lons -1 - xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) - ENDDO - xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) - - DO j = 1, lats -1 - ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) - ENDDO - ENDIF -c - - invlev = .FALSE. - IF( ztemp(1).LT.ztemp(levs) ) invlev = .TRUE. - - presmax = MAX( ztemp(1), ztemp(levs) ) - IF( presmax.LT.1200. ) THEN - DO l = 1,levs - ztemp(l) = ztemp(l) * 100. - ENDDO - ENDIF - - IF( invlev ) THEN - - IF(.NOT.alloc) THEN - ALLOCATE(champf(lons,lats,levs)) - alloc = .TRUE. - ENDIF - - DO l = 1,levs - zf(l) = ztemp(l) - ENDDO - - DO l = 1,levs - DO j = 1, lats - DO i = 1,lons - champf(i,j,l) = champd(i,j,l) - ENDDO - ENDDO - ENDDO - - DO l = 1,levs - ztemp(levs+1-l) = zf(l) - ENDDO - - DO l = 1,levs - DO j = 1, lats - DO i = 1,lons - champd(i,j,levs+1-l) = champf(i,j,l) - ENDDO - ENDDO - ENDDO - - - ENDIF - - IF(alloc) DEALLOCATE(champf) - - DO i = 1, lons - xf(i) = xtemp(i) - ENDDO - DO j = 1, lats - yf(j) = ytemp(j) - ENDDO - DO l = 1, levs - zf(l) = ztemp(l) - ENDDO - - DEALLOCATE(xtemp) - DEALLOCATE(ytemp) - DEALLOCATE(ztemp) - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/conf_planete.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/conf_planete.F90 (revision 1944) +++ (revision ) @@ -1,70 +1,0 @@ -! -! $Id$ -! -SUBROUTINE conf_planete -! -#ifdef CPP_IOIPSL -USE IOIPSL -#else -! if not using IOIPSL, we still need to use (a local version of) getin -USE ioipsl_getincom -#endif -IMPLICIT NONE -! -! -! Declarations : -! -------------- -#include "dimensions.h" -#include "comconst.h" -#include "comvert.h" -! -! local: -! ------ - -! --------------------------------------------- -! Initialisations de constantes de la dynamique -! --------------------------------------------- -! Pi -pi=2.*asin(1.) - -!Reference surface pressure (Pa) -preff=101325. -CALL getin('preff', preff) -! Reference pressure at which hybrid coord. become purely pressure -! pa=50000. -pa=preff/2. -CALL getin('pa', pa) -! Gravity -g=9.80665 -CALL getin('g',g) -! Molar mass of the atmosphere -molmass = 28.9644 -CALL getin('molmass',molmass) -! kappa=R/Cp et Cp -kappa = 2./7. -CALL getin('kappa',kappa) -cpp=8.3145/molmass/kappa*1000. -CALL getin('cpp',cpp) -! Radius of the planet -rad = 6371229. -CALL getin('radius',rad) -! Length of a standard day (s) -daysec=86400. -CALL getin('daysec',daysec) -! Rotation rate of the planet: -! Length of a solar day, in standard days -daylen = 1. -CALL getin('daylen',daylen) -! Number of days (standard) per year: -year_day = 365.25 -CALL getin('year_day',year_day) -! Omega -! omeg=2.*pi/86400. -omeg=2.*pi/daysec*(1./daylen+1./year_day) -CALL getin('omeg',omeg) - -! Intrinsic heat flux (default: none) (only used if planet_type="giant") -ihf = 0. -call getin('ihf',ihf) - -END SUBROUTINE conf_planete Index: LMDZ5/trunk/libf/dyn3dmem/convflu.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/convflu.F (revision 1944) +++ (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: LMDZ5/trunk/libf/dyn3dmem/convmas.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/convmas.F (revision 1944) +++ (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: LMDZ5/trunk/libf/dyn3dmem/coordij.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/coordij.F (revision 1944) +++ (revision ) @@ -1,48 +1,0 @@ -! -! $Header$ -! - SUBROUTINE coordij(lon,lat,ilon,jlat) - -c======================================================================= -c -c calcul des coordonnees i et j de la maille scalaire dans -c laquelle se trouve le point (lon,lat) en radian -c -c======================================================================= - - IMPLICIT NONE - REAL lon,lat - INTEGER ilon,jlat - INTEGER i,j - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comgeom.h" -#include "serre.h" - - real zlon,zlat - - zlon=lon*pi/180. - zlat=lat*pi/180. - - DO i=1,iim+1 - IF (rlonu(i).GT.zlon) THEN - ilon=i - GOTO 10 - ENDIF - ENDDO -10 CONTINUE - - j=0 - DO j=1,jjm - IF(rlatv(j).LT.zlat) THEN - jlat=j - GOTO 20 - ENDIF - ENDDO -20 CONTINUE - IF(j.EQ.0) j=jjm+1 - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/covcont.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/covcont.F (revision 1944) +++ (revision ) @@ -1,43 +1,0 @@ -! -! $Header$ -! - SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont ) - IMPLICIT NONE - -c======================================================================= -c -c Auteur: P. Le Van -c ------- -c -c Objet: -c ------ -c -c ********************************************************************* -c calcul des compos. contravariantes 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 ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel ) - INTEGER l,ij - - - DO 10 l = 1,klevel - - DO 2 ij = iip2, ip1jm - ucont( ij,l ) = ucov( ij,l ) * unscu2( ij ) - 2 CONTINUE - - DO 4 ij = 1,ip1jm - vcont( ij,l ) = vcov( ij,l ) * unscv2( ij ) - 4 CONTINUE - - 10 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/diverg.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/diverg.F (revision 1944) +++ (revision ) @@ -1,85 +1,0 @@ -! -! $Header$ -! - SUBROUTINE diverg(klevel,x,y,div) -c -c P. Le Van -c -c ********************************************************************* -c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. -c x et y... -c x et y etant des composantes covariantes ... -c ********************************************************************* - IMPLICIT NONE -c -c x et y sont des arguments d'entree pour le s-prog -c div est un argument de sortie pour le s-prog -c -c -c --------------------------------------------------------------------- -c -c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . -c -c --------------------------------------------------------------------- -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" -c -c .......... variables en arguments ................... -c - INTEGER klevel - REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) - INTEGER l,ij -c -c ............... variables locales ......................... - - REAL aiy1( iip1 ) , aiy2( iip1 ) - REAL sumypn,sumyps -c ................................................................... -c - REAL SSUM -c -c - DO 10 l = 1,klevel -c - DO ij = iip2, ip1jm - 1 - div( ij + 1, l ) = - * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + - * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) - ENDDO -c -c .... correction pour div( 1,j,l) ...... -c .... div(1,j,l)= div(iip1,j,l) .... -c -CDIR$ IVDEP - DO ij = iip2,ip1jm,iip1 - div( ij,l ) = div( ij + iim,l ) - ENDDO -c -c .... calcul aux poles ..... -c - DO ij = 1,iim - aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) - aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) - ENDDO - sumypn = SSUM ( iim,aiy1,1 ) / apoln - sumyps = SSUM ( iim,aiy2,1 ) / apols -c - DO ij = 1,iip1 - div( ij , l ) = - sumypn - div( ij + ip1jm, l ) = sumyps - ENDDO - 10 CONTINUE -c - -ccc CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) - -c - DO l = 1, klevel - DO ij = iip2,ip1jm - div(ij,l) = div(ij,l) * unsaire(ij) - ENDDO - ENDDO -c - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/diverg_gam.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/diverg_gam.F (revision 1944) +++ (revision ) @@ -1,80 +1,0 @@ -! -! $Header$ -! - SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam , - * unsapolnga,unsapolsga, x, y, div ) -c -c P. Le Van -c -c ********************************************************************* -c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. -c x et y... -c x et y etant des composantes covariantes ... -c ********************************************************************* - IMPLICIT NONE -c -c x et y sont des arguments d'entree pour le s-prog -c div est un argument de sortie pour le s-prog -c -c -c --------------------------------------------------------------------- -c -c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . -c -c --------------------------------------------------------------------- -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" -c -c .......... variables en arguments ................... -c - INTEGER klevel - REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) - REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1) - REAL unsapolnga,unsapolsga -c -c ............... variables locales ......................... - - REAL aiy1( iip1 ) , aiy2( iip1 ) - REAL sumypn,sumyps - INTEGER l,ij -c ................................................................... -c - REAL SSUM -c -c - DO 10 l = 1,klevel -c - DO ij = iip2, ip1jm - 1 - div( ij + 1, l ) = ( - * cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + - * cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* - * unsairegam( ij+1 ) - ENDDO -c -c .... correction pour div( 1,j,l) ...... -c .... div(1,j,l)= div(iip1,j,l) .... -c -CDIR$ IVDEP - DO ij = iip2,ip1jm,iip1 - div( ij,l ) = div( ij + iim,l ) - ENDDO -c -c .... calcul aux poles ..... -c - DO ij = 1,iim - aiy1(ij) = cuvscvgam( ij ) * y( ij , l ) - aiy2(ij) = cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) - ENDDO - sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga - sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga -c - DO ij = 1,iip1 - div( ij , l ) = - sumypn - div( ij + ip1jm, l ) = sumyps - ENDDO - 10 CONTINUE -c - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/divergf.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/divergf.F (revision 1944) +++ (revision ) @@ -1,85 +1,0 @@ -! -! $Header$ -! - SUBROUTINE divergf(klevel,x,y,div) -c -c P. Le Van -c -c ********************************************************************* -c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. -c x et y... -c x et y etant des composantes covariantes ... -c ********************************************************************* - IMPLICIT NONE -c -c x et y sont des arguments d'entree pour le s-prog -c div est un argument de sortie pour le s-prog -c -c -c --------------------------------------------------------------------- -c -c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . -c -c --------------------------------------------------------------------- -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" -c -c .......... variables en arguments ................... -c - INTEGER klevel - REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) - INTEGER l,ij -c -c ............... variables locales ......................... - - REAL aiy1( iip1 ) , aiy2( iip1 ) - REAL sumypn,sumyps -c ................................................................... -c - REAL SSUM -c -c - DO 10 l = 1,klevel -c - DO ij = iip2, ip1jm - 1 - div( ij + 1, l ) = - * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + - * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) - ENDDO -c -c .... correction pour div( 1,j,l) ...... -c .... div(1,j,l)= div(iip1,j,l) .... -c -CDIR$ IVDEP - DO ij = iip2,ip1jm,iip1 - div( ij,l ) = div( ij + iim,l ) - ENDDO -c -c .... calcul aux poles ..... -c - DO ij = 1,iim - aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) - aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) - ENDDO - sumypn = SSUM ( iim,aiy1,1 ) / apoln - sumyps = SSUM ( iim,aiy2,1 ) / apols -c - DO ij = 1,iip1 - div( ij , l ) = - sumypn - div( ij + ip1jm, l ) = sumyps - ENDDO - 10 CONTINUE -c - - CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) - -c - DO l = 1, klevel - DO ij = iip2,ip1jm - div(ij,l) = div(ij,l) * unsaire(ij) - ENDDO - ENDDO -c - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/divergst.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/divergst.F (revision 1944) +++ (revision ) @@ -1,62 +1,0 @@ -! -! $Header$ -! - SUBROUTINE divergst(klevel,x,y,div) - IMPLICIT NONE -c -c P. Le Van -c -c ****************************************************************** -c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y... -c x et y etant des composantes contravariantes ... -c **************************************************************** -c x et y sont des arguments d'entree pour le s-prog -c div est un argument de sortie pour le s-prog -c -c -c ------------------------------------------------------------------- -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - - INTEGER klevel - REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) - INTEGER ij,l,i - REAL aiy1( iip1 ) , aiy2( iip1 ) - REAL sumypn,sumyps - - REAL SSUM -c -c - DO 10 l = 1,klevel -c - DO 1 ij = iip2, ip1jm - 1 - div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l) - 1 CONTINUE -c -c .... correction pour div( 1,j,l) ...... -c .... div(1,j,l)= div(iip1,j,l) .... -c -CDIR$ IVDEP - DO 3 ij = iip2,ip1jm,iip1 - div( ij,l ) = div( ij + iim,l ) - 3 CONTINUE -c -c .... calcul aux poles ..... -c -c - DO 5 i = 1,iim - aiy1(i)= y(i,l) - aiy2(i)= y(i+ip1jmi1,l) - 5 CONTINUE - sumypn = SSUM ( iim,aiy1,1 ) - sumyps = SSUM ( iim,aiy2,1 ) - DO 7 i = 1,iip1 - div( i , l ) = - sumypn/iim - div( i + ip1jm, l ) = sumyps/iim - 7 CONTINUE -c - 10 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/divgrad.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/divgrad.F (revision 1944) +++ (revision ) @@ -1,56 +1,0 @@ -! -! $Header$ -! - SUBROUTINE divgrad (klevel,h, lh, divgra ) - IMPLICIT NONE -c -c======================================================================= -c -c Auteur : P. Le Van -c ---------- -c -c lh -c calcul de (div( grad )) de h ..... -c h et lh sont des arguments d'entree pour le s-prog -c divgra est un argument de sortie pour le s-prog -c -c======================================================================= -c -c declarations: -c ------------- -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" -#include "comdissipn.h" -#include "logic.h" -c - INTEGER klevel - REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) -c - REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) - - INTEGER l,ij,iter,lh -c -c -c - CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 ) -c - DO 10 iter = 1,lh - - CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1 ) - - CALL grad (klevel,divgra, ghx , ghy ) - CALL diverg (klevel, ghx , ghy , divgra ) - - CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1) - - DO 5 l = 1,klevel - DO 4 ij = 1, ip1jmp1 - divgra( ij,l ) = - cdivh * divgra( ij,l ) - 4 CONTINUE - 5 CONTINUE -c - 10 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/divgrad2.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/divgrad2.F (revision 1944) +++ (revision ) @@ -1,79 +1,0 @@ -! -! $Header$ -! - SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra ) -c -c P. Le Van -c -c *************************************************************** -c -c ..... calcul de (div( grad )) de ( pext * h ) ..... -c **************************************************************** -c h ,klevel,lh et pext sont des arguments d'entree pour le s-prg -c divgra est un argument de sortie pour le s-prg -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom2.h" -#include "comdissipn.h" - -c ....... variables en arguments ....... -c - INTEGER klevel - REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel ) - REAL divgra( ip1jmp1,klevel) -c -c ....... variables locales .......... -c - REAL signe, nudivgrs, sqrtps( ip1jmp1,llm ) - INTEGER l,ij,iter,lh -c ................................................................... - -c - signe = (-1.)**lh - nudivgrs = signe * cdivh - - CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 ) - -c - CALL laplacien( klevel, divgra, divgra ) - - DO l = 1, klevel - DO ij = 1, ip1jmp1 - sqrtps( ij,l ) = SQRT( deltapres(ij,l) ) - ENDDO - ENDDO -c - DO l = 1, klevel - DO ij = 1, ip1jmp1 - divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) - ENDDO - ENDDO - -c ........ Iteration de l'operateur laplacien_gam ........ -c - DO iter = 1, lh - 2 - CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2, - * unsapolnga2, unsapolsga2, divgra, divgra ) - ENDDO -c -c ............................................................... - - DO l = 1, klevel - DO ij = 1, ip1jmp1 - divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) - ENDDO - ENDDO -c - CALL laplacien ( klevel, divgra, divgra ) -c - DO l = 1,klevel - DO ij = 1,ip1jmp1 - divgra(ij,l) = nudivgrs * divgra(ij,l) / deltapres(ij,l) - ENDDO - ENDDO - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/enercin.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/enercin.F (revision 1944) +++ (revision ) @@ -1,98 +1,0 @@ -! -! $Header$ -! - SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin ) - IMPLICIT NONE - -c======================================================================= -c -c Auteur: P. Le Van -c ------- -c -c Objet: -c ------ -c -c ********************************************************************* -c .. calcul de l'energie cinetique aux niveaux s ...... -c ********************************************************************* -c vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg . -c ecin est un argument de sortie pour le s-pg -c -c======================================================================= - -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - - REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ), - * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm ) - - REAL ecinni( iip1 ),ecinsi( iip1 ) - - REAL ecinpn, ecinps - INTEGER l,ij,i - - REAL SSUM - - - -c . V -c i,j-1 - -c alpha4 . . alpha1 - - -c U . . P . U -c i-1,j i,j i,j - -c alpha3 . . alpha2 - - -c . V -c i,j - -c -c L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est : -c Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 ) + -c 0.5 * U(i ,j)**2 *( alpha1 + alpha2 ) + -c 0.5 * V(i,j-1)**2 *( alpha1 + alpha4 ) + -c 0.5 * V(i, j)**2 *( alpha2 + alpha3 ) - - - DO 5 l = 1,llm - - DO 1 ij = iip2, ip1jm -1 - ecin( ij+1, l ) = 0.5 * - * ( ucov( ij ,l ) * ucont( ij ,l ) * alpha3p4( ij +1 ) + - * ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 ) + - * vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 ) + - * vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 ) ) - 1 CONTINUE - -c ... correction pour ecin(1,j,l) .... -c ... ecin(1,j,l)= ecin(iip1,j,l) ... - -CDIR$ IVDEP - DO 2 ij = iip2, ip1jm, iip1 - ecin( ij,l ) = ecin( ij + iim, l ) - 2 CONTINUE - -c calcul aux poles ....... - - - DO 3 i = 1, iim - ecinni(i) = vcov( i , l) * vcont( i ,l) * aire( i ) - ecinsi(i) = vcov(i+ip1jmi1,l) * vcont(i+ip1jmi1,l) * aire(i+ip1jm) - 3 CONTINUE - - ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln - ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols - - DO 4 ij = 1,iip1 - ecin( ij , l ) = ecinpn - ecin( ij+ ip1jm, l ) = ecinps - 4 CONTINUE - - 5 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/exner_milieu.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/exner_milieu.F (revision 1944) +++ (revision ) @@ -1,144 +1,0 @@ -! -! $Id$ -! - SUBROUTINE exner_milieu ( ngrid, ps, p,beta, pks, pk, pkf ) -c -c Auteurs : F. Forget , Y. Wanherdrick -c P.Le Van , Fr. Hourdin . -c .......... -c -c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... -c .... beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... -c -c ************************************************************************ -c Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des -c couches . Pk(l) sera calcule aux milieux des couches l ,entre les -c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . -c ************************************************************************ -c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont -c la pression et la fonction d'Exner au sol . -c -c WARNING : CECI est une version speciale de exner_hyb originale -c Utilise dans la version martienne pour pouvoir -c tourner avec des coordonnees verticales complexe -c => Il ne verifie PAS la condition la proportionalite en -c energie totale/ interne / potentielle (F.Forget 2001) -c ( voir note de Fr.Hourdin ) , -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comgeom.h" -#include "comvert.h" -#include "serre.h" - - INTEGER ngrid - REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) - REAL ps(ngrid),pks(ngrid), beta(ngrid,llm) - -c .... variables locales ... - - INTEGER l, ij - REAL dum1 - - REAL ppn(iim),pps(iim) - REAL xpn, xps - REAL SSUM - EXTERNAL SSUM - logical,save :: firstcall=.true. - character(len=*),parameter :: modname="exner_milieu" - - ! Sanity check - if (firstcall) then - ! sanity checks for Shallow Water case (1 vertical layer) - if (llm.eq.1) then - if (kappa.ne.1) then - call abort_gcm(modname, - & "kappa!=1 , but running in Shallow Water mode!!",42) - endif - if (cpp.ne.r) then - call abort_gcm(modname, - & "cpp!=r , but running in Shallow Water mode!!",42) - endif - endif ! of if (llm.eq.1) - - firstcall=.false. - endif ! of if (firstcall) - -!!!! Specific behaviour for Shallow Water (1 vertical layer) case: - if (llm.eq.1) then - - ! Compute pks(:),pk(:),pkf(:) - - DO ij = 1, ngrid - pks(ij) = (cpp/preff) * ps(ij) - pk(ij,1) = .5*pks(ij) - ENDDO - - CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) - CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) - - ! our work is done, exit routine - return - - endif ! of if (llm.eq.1) - -!!!! General case: - -c ------------- -c Calcul de pks -c ------------- - - DO ij = 1, ngrid - pks(ij) = cpp * ( ps(ij)/preff ) ** kappa - ENDDO - - DO ij = 1, iim - ppn(ij) = aire( ij ) * pks( ij ) - pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) - ENDDO - xpn = SSUM(iim,ppn,1) /apoln - xps = SSUM(iim,pps,1) /apols - - DO ij = 1, iip1 - pks( ij ) = xpn - pks( ij+ip1jm ) = xps - ENDDO -c -c -c .... Calcul de pk pour la couche l -c -------------------------------------------- -c - dum1 = cpp * (2*preff)**(-kappa) - DO l = 1, llm-1 - DO ij = 1, ngrid - pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa - ENDDO - ENDDO - -c .... Calcul de pk pour la couche l = llm .. -c (on met la meme distance (en log pression) entre Pk(llm) -c et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) - - DO ij = 1, ngrid - pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2) - ENDDO - - -c calcul de pkf -c ------------- - CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) - CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) - -c EST-CE UTILE ?? : calcul de beta -c -------------------------------- - DO l = 2, llm - DO ij = 1, ngrid - beta(ij,l) = pk(ij,l) / pk(ij,l-1) - ENDDO - ENDDO - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/flumass.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/flumass.F (revision 1944) +++ (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: LMDZ5/trunk/libf/dyn3dmem/fxyhyper.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/fxyhyper.F (revision 1944) +++ (revision ) @@ -1,139 +1,0 @@ -! -! $Header$ -! -c -c - SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy , - , xzoom, grossx, dzoomx,taux , - , rlatu,yprimu,rlatv,yprimv,rlatu1, yprimu1, rlatu2, yprimu2 , - , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) - - IMPLICIT NONE -c -c Auteur : P. Le Van . -c -c d'apres formulations de R. Sadourny . -c -c -c Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp ) -c par des fonctions a tangente hyperbolique . -c -c Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom -c et yzoom ) : -c -c a) le grossissement du zoom : grossy ( en y ) et grossx ( en x ) -c b) l' extension du zoom : dzoomy ( en y ) et dzoomx ( en x ) -c c) la raideur de la transition du zoom : taux et tauy -c -c N.B : Il vaut mieux avoir : grossx * dzoomx < pi ( radians ) -c ****** -c et grossy * dzoomy < pi/2 ( radians ) -c -#include "dimensions.h" -#include "paramet.h" - - -c ..... Arguments ... -c - REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy - REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), - , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) - REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), - , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) - REAL(KIND=8) dxmin, dxmax , dymin, dymax - -c .... var. locales ..... -c - INTEGER i,j -c - - CALL fyhyp ( yzoom, grossy, dzoomy,tauy , - , rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 , - , dymin,dymax ) - - CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv, - , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax ) - - - DO i = 1, iip1 - IF(rlonp025(i).LT.rlonv(i)) THEN - WRITE(6,*) ' Attention ! rlonp025 < rlonv',i - STOP - ENDIF - - IF(rlonv(i).LT.rlonm025(i)) THEN - WRITE(6,*) ' Attention ! rlonm025 > rlonv',i - STOP - ENDIF - - IF(rlonp025(i).GT.rlonu(i)) THEN - WRITE(6,*) ' Attention ! rlonp025 > rlonu',i - STOP - ENDIF - ENDDO - - WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FX **** ' - -c - DO j = 1, jjm -c - IF(rlatu1(j).LE.rlatu2(j)) THEN - WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j - STOP 13 - ENDIF -c - IF(rlatu2(j).LE.rlatu(j+1)) THEN - WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j - STOP 14 - ENDIF -c - IF(rlatu(j).LE.rlatu1(j)) THEN - WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j - STOP 15 - ENDIF -c - IF(rlatv(j).LE.rlatu2(j)) THEN - WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j - STOP 16 - ENDIF -c - IF(rlatv(j).ge.rlatu1(j)) THEN - WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j - STOP 17 - ENDIF -c - IF(rlatv(j).ge.rlatu(j)) THEN - WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j - STOP 18 - ENDIF -c - ENDDO -c - WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FY **** ' -c - WRITE(6,18) - WRITE(6,*) ' Latitudes ' - WRITE(6,*) ' *********** ' - WRITE(6,18) - WRITE(6,3) dymin, dymax - WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par - ,ametres grossism , tau , dzoom pour Y et repasser ! ' -c - WRITE(6,18) - WRITE(6,*) ' Longitudes ' - WRITE(6,*) ' ************ ' - WRITE(6,18) - WRITE(6,3) dxmin, dxmax - WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par - ,ametres grossism , tau , dzoom pour Y et repasser ! ' - WRITE(6,18) -c -3 Format(1x, ' Au centre du zoom , la longueur de la maille est', - , ' d environ ',f8.2 ,' degres ', - , ' alors que la maille en dehors de la zone du zoom est d environ - , ', f8.2,' degres ' ) -18 FORMAT(/) - - RETURN - END - Index: LMDZ5/trunk/libf/dyn3dmem/geopot.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/geopot.F (revision 1944) +++ (revision ) @@ -1,64 +1,0 @@ -! -! $Header$ -! - SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi ) - IMPLICIT NONE - -c======================================================================= -c -c Auteur: P. Le Van -c ------- -c -c Objet: -c ------ -c -c ******************************************************************* -c .... calcul du geopotentiel aux milieux des couches ..... -c ******************************************************************* -c -c .... l'integration se fait de bas en haut .... -c -c .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg .. -c phi est un argum. de sortie pour le s-pg . -c -c======================================================================= -c----------------------------------------------------------------------- -c Declarations: -c ------------- - -#include "dimensions.h" -#include "paramet.h" -#include "comvert.h" - -c Arguments: -c ---------- - - INTEGER ngrid - REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) , - * phi(ngrid,llm) - - -c Local: -c ------ - - INTEGER l, ij - - -c----------------------------------------------------------------------- -c calcul de phi au niveau 1 pres du sol ..... - - DO 1 ij = 1, ngrid - phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) ) - 1 CONTINUE - -c calcul de phi aux niveaux superieurs ....... - - DO l = 2,llm - DO ij = 1,ngrid - phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l) + teta(ij,l-1) ) - * * ( pk(ij,l-1) - pk(ij,l) ) - ENDDO - ENDDO - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/gr_dyn_fi.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/gr_dyn_fi.F (revision 1944) +++ (revision ) @@ -1,38 +1,0 @@ -! -! $Header$ -! - SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi) - IMPLICIT NONE -c======================================================================= -c passage d'un champ de la grille scalaire a la grille physique -c======================================================================= - -c----------------------------------------------------------------------- -c declarations: -c ------------- - - INTEGER im,jm,ngrid,nfield - REAL pdyn(im,jm,nfield) - REAL pfi(ngrid,nfield) - - INTEGER j,ifield,ig - -c----------------------------------------------------------------------- -c calcul: -c ------- - - IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim' -c traitement des poles - CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid) - CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid) - -c traitement des point normaux - DO ifield=1,nfield - DO j=2,jm-1 - ig=2+(j-2)*(im-1) - CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1) - ENDDO - ENDDO - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/gr_ecrit_fi.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/gr_ecrit_fi.F (revision 1944) +++ (revision ) @@ -1,32 +1,0 @@ -! -! $Header$ -! - SUBROUTINE gr_ecrit_fi(nfield,nlon,iim,jjmp1,ecrit,fi) - - IMPLICIT none - -c Transformer une variable de la grille d'ecriture a la grille physique - - INTEGER nfield,nlon,iim,jjmp1, jjm - REAL fi(nlon,nfield), ecrit(iim,jjmp1,nfield) -c - INTEGER i, j, n, ig -c -c print*,'iim jjm ',iim,jjm - -c modif par abd 21 02 01 - - jjm = jjmp1 - 1 - do n = 1, nfield - fi(1,n) = ecrit(1,1,n) - fi(nlon,n) = ecrit(1,jjm+1,n) - DO j = 2, jjm - ig = 2+(j-2)*iim - DO i = 1, iim - fi(ig-1+i,n) = ecrit(i,j,n) - ENDDO - ENDDO - ENDDO - RETURN - END - Index: LMDZ5/trunk/libf/dyn3dmem/gr_fi_dyn.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/gr_fi_dyn.F (revision 1944) +++ (revision ) @@ -1,40 +1,0 @@ -! -! $Header$ -! - SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn) - IMPLICIT NONE -c======================================================================= -c passage d'un champ de la grille scalaire a la grille physique -c======================================================================= - -c----------------------------------------------------------------------- -c declarations: -c ------------- - - INTEGER im,jm,ngrid,nfield - REAL pdyn(im,jm,nfield) - REAL pfi(ngrid,nfield) - - INTEGER i,j,ifield,ig - -c----------------------------------------------------------------------- -c calcul: -c ------- - - DO ifield=1,nfield -c traitement des poles - DO i=1,im - pdyn(i,1,ifield)=pfi(1,ifield) - pdyn(i,jm,ifield)=pfi(ngrid,ifield) - ENDDO - -c traitement des point normaux - DO j=2,jm-1 - ig=2+(j-2)*(im-1) - CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1) - pdyn(im,j,ifield)=pdyn(1,j,ifield) - ENDDO - ENDDO - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/gr_int_dyn.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/gr_int_dyn.F (revision 1944) +++ (revision ) @@ -1,49 +1,0 @@ -! -! $Header$ -! - subroutine gr_int_dyn(champin,champdyn,iim,jp1) - implicit none -c======================================================================= -c passage d'un champ interpole a un champ sur grille scalaire -c======================================================================= -c----------------------------------------------------------------------- -c declarations: -c ------------- - - INTEGER iim - integer ip1, jp1 - REAL champin(iim, jp1) - REAL champdyn(iim+1, jp1) - - INTEGER i, j - real polenord, polesud - -c----------------------------------------------------------------------- -c calcul: -c ------- - - ip1 = iim + 1 - polenord = 0. - polesud = 0. - do i = 1, iim - polenord = polenord + champin (i, 1) - polesud = polesud + champin (i, jp1) - enddo - polenord = polenord / iim - polesud = polesud / iim - do j = 1, jp1 - do i = 1, iim - if (j .eq. 1) then - champdyn(i, j) = polenord - else if (j .eq. jp1) then - champdyn(i, j) = polesud - else - champdyn(i, j) = champin (i, j) - endif - enddo - champdyn(ip1, j) = champdyn(1, j) - enddo - - RETURN - END - Index: LMDZ5/trunk/libf/dyn3dmem/gr_u_scal.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/gr_u_scal.F (revision 1944) +++ (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: LMDZ5/trunk/libf/dyn3dmem/gr_v_scal.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/gr_v_scal.F (revision 1944) +++ (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: LMDZ5/trunk/libf/dyn3dmem/grad.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/grad.F (revision 1944) +++ (revision ) @@ -1,44 +1,0 @@ -! -! $Header$ -! - SUBROUTINE grad(klevel, pg,pgx,pgy ) -c -c P. Le Van -c -c ****************************************************************** -c .. calcul des composantes covariantes en x et y du gradient de g -c -c ****************************************************************** -c pg est un argument d'entree pour le s-prog -c pgx et pgy sont des arguments de sortie pour le s-prog -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" - INTEGER klevel - REAL pg( ip1jmp1,klevel ) - REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel ) - INTEGER l,ij -c -c - DO 6 l = 1,klevel -c - DO 2 ij = 1, ip1jmp1 - 1 - pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) - 2 CONTINUE -c -c .... correction pour pgx(ip1,j,l) .... -c ... pgx(iip1,j,l)= pgx(1,j,l) .... -CDIR$ IVDEP - DO 3 ij = iip1, ip1jmp1, iip1 - pgx( ij,l ) = pgx( ij -iim,l ) - 3 CONTINUE -c - DO 4 ij = 1,ip1jm - pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) - 4 CONTINUE -c - 6 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/gradiv.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/gradiv.F (revision 1944) +++ (revision ) @@ -1,57 +1,0 @@ -! -! $Header$ -! - SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy ) -c -c Auteur : P. Le Van -c -c *************************************************************** -c -c ld -c calcul de (grad (div) ) du vect. v .... -c -c xcov et ycov etant les composant.covariantes de v -c **************************************************************** -c xcov , ycov et ld sont des arguments d'entree pour le s-prog -c gdx et gdy sont des arguments de sortie pour le s-prog -c -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comdissipn.h" -#include "logic.h" - - INTEGER klevel -c - REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) - REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) - - REAL div(ip1jmp1,llm) - - INTEGER l,ij,iter,ld -c -c -c - CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 ) - CALL SCOPY( ip1jm*klevel, ycov,1,gdy,1 ) -c - DO 10 iter = 1,ld -c - CALL diverg( klevel, gdx , gdy, div ) - CALL filtreg( div, jjp1, klevel, 2,1, .true.,2 ) - CALL grad( klevel, div, gdx, gdy ) -c - DO 5 l = 1, klevel - DO 3 ij = 1, ip1jmp1 - gdx( ij,l ) = - gdx( ij,l ) * cdivu - 3 CONTINUE - DO 4 ij = 1, ip1jm - gdy( ij,l ) = - gdy( ij,l ) * cdivu - 4 CONTINUE - 5 CONTINUE -c - 10 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/gradiv2.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/gradiv2.F (revision 1944) +++ (revision ) @@ -1,79 +1,0 @@ -! -! $Header$ -! - SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy ) -c -c P. Le Van -c -c ********************************************************** -c ld -c calcul de (grad (div) ) du vect. v .... -c -c xcov et ycov etant les composant.covariantes de v -c ********************************************************** -c xcont , ycont et ld sont des arguments d'entree pour le s-prog -c gdx et gdy sont des arguments de sortie pour le s-prog -c -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" -#include "comdissipn.h" -c -c ........ variables en arguments ........ - - INTEGER klevel - REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) - REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) -c -c ........ variables locales ......... -c - REAL div(ip1jmp1,llm) - REAL signe, nugrads - INTEGER l,ij,iter,ld - -c ........................................................ -c -c - CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 ) - CALL SCOPY( ip1jm * klevel, ycov, 1, gdy, 1 ) -c -c - signe = (-1.)**ld - nugrads = signe * cdivu -c - - - CALL divergf( klevel, gdx, gdy , div ) - - IF( ld.GT.1 ) THEN - - CALL laplacien ( klevel, div, div ) - -c ...... Iteration de l'operateur laplacien_gam ....... - - DO iter = 1, ld -2 - CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1, - * unsapolnga1, unsapolsga1, div, div ) - ENDDO - - ENDIF - - - CALL filtreg( div , jjp1, klevel, 2, 1, .TRUE., 1 ) - CALL grad ( klevel, div, gdx, gdy ) - -c - DO l = 1, klevel - DO ij = 1, ip1jmp1 - gdx( ij,l ) = gdx( ij,l ) * nugrads - ENDDO - DO ij = 1, ip1jm - gdy( ij,l ) = gdy( ij,l ) * nugrads - ENDDO - ENDDO -c - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/gradsdef.h =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/gradsdef.h (revision 1944) +++ (revision ) @@ -1,23 +1,0 @@ -! -! $Header$ -! - integer nfmx,imx,jmx,lmx,nvarmx - parameter(nfmx=10,imx=200,jmx=150,lmx=200,nvarmx=1000) - - real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx) - - integer imd(imx),jmd(jmx),lmd(lmx) - integer iid(imx),jid(jmx) - integer ifd(imx),jfd(jmx) - integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx) - - integer nvar(nfmx),ivar(nfmx) - logical firsttime(nfmx) - - character*10 var(nvarmx,nfmx),fichier(nfmx) - character*40 title(nfmx),tvar(nvarmx,nfmx) - - common/gradsdef/xd,yd,zd,dtime, - s imd,jmd,lmd,iid,jid,ifd,jfd, - s unit,irec,nvar,ivar,itime,nld,firsttime, - s var,fichier,title,tvar Index: LMDZ5/trunk/libf/dyn3dmem/heavyside.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/heavyside.F (revision 1944) +++ (revision ) @@ -1,23 +1,0 @@ -! -! $Header$ -! -c -c - FUNCTION heavyside(a) - -c ... P. Le Van .... -c - IMPLICIT NONE - - REAL(KIND=8) heavyside , a - - IF ( a.LE.0. ) THEN - heavyside = 0. - ELSE - heavyside = 1. - ENDIF - - RETURN - END - - Index: LMDZ5/trunk/libf/dyn3dmem/infotrac.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/infotrac.F90 (revision 1944) +++ (revision ) @@ -1,390 +1,0 @@ -! $Id$ -! -MODULE infotrac - -! nqtot : total number of tracers and higher order of moment, water vapor and liquid included - INTEGER, SAVE :: nqtot - -! nbtr : number of tracers not including higher order of moment or water vapor or liquid -! number of tracers used in the physics - INTEGER, SAVE :: nbtr - -! Name variables - CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics - CHARACTER(len=23), ALLOCATABLE, DIMENSION(:), SAVE :: ttext ! tracer long name for diagnostics - -! iadv : index of trasport schema for each tracer - INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: iadv - -! niadv : vector keeping the coorspondance between all tracers(nqtot) treated in the -! dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code. - INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: niadv ! equivalent dyn / physique - -! conv_flg(it)=0 : convection desactivated for tracer number it - INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: conv_flg -! pbl_flg(it)=0 : boundary layer diffusion desactivaded for tracer number it - INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: pbl_flg - - CHARACTER(len=4),SAVE :: type_trac - -CONTAINS - - SUBROUTINE infotrac_init - USE control_mod -#ifdef REPROBUS - USE CHEM_REP, ONLY : Init_chem_rep_trac -#endif - IMPLICIT NONE -!======================================================================= -! -! Auteur: P. Le Van /L. Fairhead/F.Hourdin -! ------- -! Modif special traceur F.Forget 05/94 -! Modif M-A Filiberti 02/02 lecture de traceur.def -! -! Objet: -! ------ -! GCM LMD nouvelle grille -! -!======================================================================= -! ... modification de l'integration de q ( 26/04/94 ) .... -!----------------------------------------------------------------------- -! Declarations - - INCLUDE "dimensions.h" - INCLUDE "iniprint.h" - -! Local variables - INTEGER, ALLOCATABLE, DIMENSION(:) :: hadv ! index of horizontal trasport schema - INTEGER, ALLOCATABLE, DIMENSION(:) :: vadv ! index of vertical trasport schema - - CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0 ! tracer short name - CHARACTER(len=8), ALLOCATABLE, DIMENSION(:) :: tracnam ! name from INCA - CHARACTER(len=3), DIMENSION(30) :: descrq - CHARACTER(len=1), DIMENSION(3) :: txts - CHARACTER(len=2), DIMENSION(9) :: txtp - CHARACTER(len=23) :: str1,str2 - - INTEGER :: nqtrue ! number of tracers read from tracer.def, without higer order of moment - INTEGER :: iq, new_iq, iiq, jq, ierr - - character(len=*),parameter :: modname="infotrac_init" -!----------------------------------------------------------------------- -! Initialization : -! - txts=(/'x','y','z'/) - txtp=(/'x ','y ','z ','xx','xy','xz','yy','yz','zz'/) - - descrq(14)='VLH' - descrq(10)='VL1' - descrq(11)='VLP' - descrq(12)='FH1' - descrq(13)='FH2' - descrq(16)='PPM' - descrq(17)='PPS' - descrq(18)='PPP' - descrq(20)='SLP' - descrq(30)='PRA' - - - ! Coherence test between parameter type_trac, config_inca and preprocessing keys - IF (type_trac=='inca') THEN - WRITE(lunout,*) 'You have choosen to couple with INCA chemestry model : type_trac=', & - type_trac,' config_inca=',config_inca - IF (config_inca/='aero' .AND. config_inca/='chem') THEN - WRITE(lunout,*) 'Incoherence between type_trac and config_inca. Model stops. Modify run.def' - CALL abort_gcm('infotrac_init','Incoherence between type_trac and config_inca',1) - END IF -#ifndef INCA - WRITE(lunout,*) 'To run this option you must add cpp key INCA and compile with INCA code' - CALL abort_gcm('infotrac_init','You must compile with cpp key INCA',1) -#endif - ELSE IF (type_trac=='repr') THEN - WRITE(lunout,*) 'You have choosen to couple with REPROBUS chemestry model : type_trac=', type_trac -#ifndef REPROBUS - WRITE(lunout,*) 'To run this option you must add cpp key REPROBUS and compile with REPRPBUS code' - CALL abort_gcm('infotrac_init','You must compile with cpp key REPROBUS',1) -#endif - ELSE IF (type_trac == 'lmdz') THEN - WRITE(lunout,*) 'Tracers are treated in LMDZ only : type_trac=', type_trac - ELSE - WRITE(lunout,*) 'type_trac=',type_trac,' not possible. Model stops' - CALL abort_gcm('infotrac_init','bad parameter',1) - END IF - - - ! Test if config_inca is other then none for run without INCA - IF (type_trac/='inca' .AND. config_inca/='none') THEN - WRITE(lunout,*) 'config_inca will now be changed to none as you do not couple with INCA model' - config_inca='none' - END IF - - -!----------------------------------------------------------------------- -! -! 1) Get the true number of tracers + water vapor/liquid -! Here true tracers (nqtrue) means declared tracers (only first order) -! -!----------------------------------------------------------------------- - IF (type_trac == 'lmdz' .OR. type_trac == 'repr') THEN - OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr) - IF(ierr.EQ.0) THEN - WRITE(lunout,*) trim(modname),': Open traceur.def : ok' - READ(90,*) nqtrue - ELSE - WRITE(lunout,*) trim(modname),': Problem in opening traceur.def' - WRITE(lunout,*) trim(modname),': WARNING using defaut values' - if (planet_type=='earth') then - nqtrue=4 ! Default value for Earth - else - nqtrue=1 ! Default value for other planets - endif - END IF - if ( planet_type=='earth') then - ! For Earth, water vapour & liquid tracers are not in the physics - nbtr=nqtrue-2 - else - ! Other planets (for now); we have the same number of tracers - ! in the dynamics than in the physics - nbtr=nqtrue - endif - ELSE ! type_trac=inca - ! nbtr has been read from INCA by init_const_lmdz() in gcm.F - nqtrue=nbtr+2 - END IF - - IF ((planet_type=="earth").and.(nqtrue < 2)) THEN - WRITE(lunout,*) trim(modname),': nqtrue=',nqtrue, ' is not allowded. 2 tracers is the minimum' - CALL abort_gcm('infotrac_init','Not enough tracers',1) - END IF - -! Transfert number of tracers to Reprobus - IF (type_trac == 'repr') THEN -#ifdef REPROBUS - CALL Init_chem_rep_trac(nbtr) -#endif - END IF - -! -! Allocate variables depending on nqtrue and nbtr -! - ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue)) - ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), tracnam(nbtr)) - conv_flg(:) = 1 ! convection activated for all tracers - pbl_flg(:) = 1 ! boundary layer activated for all tracers - -!----------------------------------------------------------------------- -! 2) Choix des schemas d'advection pour l'eau et les traceurs -! -! iadv = 1 schema transport type "humidite specifique LMD" -! iadv = 2 schema amont -! iadv = 14 schema Van-leer + humidite specifique -! Modif F.Codron -! iadv = 10 schema Van-leer (retenu pour l'eau vapeur et liquide) -! iadv = 11 schema Van-Leer pour hadv et version PPM (Monotone) pour vadv -! iadv = 12 schema Frederic Hourdin I -! iadv = 13 schema Frederic Hourdin II -! iadv = 16 schema PPM Monotone(Collela & Woodward 1984) -! iadv = 17 schema PPM Semi Monotone (overshoots autorisés) -! iadv = 18 schema PPM Positif Defini (overshoots undershoots autorisés) -! iadv = 20 schema Slopes -! iadv = 30 schema Prather -! -! Dans le tableau q(ij,l,iq) : iq = 1 pour l'eau vapeur -! iq = 2 pour l'eau liquide -! Et eventuellement iq = 3,nqtot pour les autres traceurs -! -! iadv(1): choix pour l'eau vap. et iadv(2) : choix pour l'eau liq. -!------------------------------------------------------------------------ -! -! Get choice of advection schema from file tracer.def or from INCA -!--------------------------------------------------------------------- - IF (type_trac == 'lmdz' .OR. type_trac == 'repr') THEN - IF(ierr.EQ.0) THEN - ! Continue to read tracer.def - DO iq=1,nqtrue - READ(90,*) hadv(iq),vadv(iq),tnom_0(iq) - END DO - CLOSE(90) - ELSE ! Without tracer.def, set default values - if (planet_type=="earth") then - ! for Earth, default is to have 4 tracers - hadv(1) = 14 - vadv(1) = 14 - tnom_0(1) = 'H2Ov' - hadv(2) = 10 - vadv(2) = 10 - tnom_0(2) = 'H2Ol' - hadv(3) = 10 - vadv(3) = 10 - tnom_0(3) = 'RN' - hadv(4) = 10 - vadv(4) = 10 - tnom_0(4) = 'PB' - else ! default for other planets - hadv(1) = 10 - vadv(1) = 10 - tnom_0(1) = 'dummy' - endif ! of if (planet_type=="earth") - END IF - - WRITE(lunout,*) trim(modname),': Valeur de traceur.def :' - WRITE(lunout,*) trim(modname),': nombre de traceurs ',nqtrue - DO iq=1,nqtrue - WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq) - END DO - - ELSE ! type_trac=inca : config_inca='aero' ou 'chem' -! le module de chimie fournit les noms des traceurs -! et les schemas d'advection associes. - -#ifdef INCA - CALL init_transport( & - hadv, & - vadv, & - conv_flg, & - pbl_flg, & - tracnam) -#endif - tnom_0(1)='H2Ov' - tnom_0(2)='H2Ol' - - DO iq =3,nqtrue - tnom_0(iq)=tracnam(iq-2) - END DO - - END IF ! type_trac - -!----------------------------------------------------------------------- -! -! 3) Verify if advection schema 20 or 30 choosen -! Calculate total number of tracers needed: nqtot -! Allocate variables depending on total number of tracers -!----------------------------------------------------------------------- - new_iq=0 - DO iq=1,nqtrue - ! Add tracers for certain advection schema - IF (hadv(iq)<20 .AND. vadv(iq)<20 ) THEN - new_iq=new_iq+1 ! no tracers added - ELSE IF (hadv(iq)==20 .AND. vadv(iq)==20 ) THEN - new_iq=new_iq+4 ! 3 tracers added - ELSE IF (hadv(iq)==30 .AND. vadv(iq)==30 ) THEN - new_iq=new_iq+10 ! 9 tracers added - ELSE - WRITE(lunout,*) trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq) - CALL abort_gcm('infotrac_init','Bad choice of advection schema - 1',1) - END IF - END DO - - IF (new_iq /= nqtrue) THEN - ! The choice of advection schema imposes more tracers - ! Assigne total number of tracers - nqtot = new_iq - - WRITE(lunout,*) trim(modname),': The choice of advection schema for one or more tracers' - WRITE(lunout,*) 'makes it necessary to add tracers' - WRITE(lunout,*) trim(modname)//': ',nqtrue,' is the number of true tracers' - WRITE(lunout,*) trim(modname)//': ',nqtot, ' is the total number of tracers needed' - - ELSE - ! The true number of tracers is also the total number - nqtot = nqtrue - END IF - -! -! Allocate variables with total number of tracers, nqtot -! - ALLOCATE(tname(nqtot), ttext(nqtot)) - ALLOCATE(iadv(nqtot), niadv(nqtot)) - -!----------------------------------------------------------------------- -! -! 4) Determine iadv, long and short name -! -!----------------------------------------------------------------------- - new_iq=0 - DO iq=1,nqtrue - new_iq=new_iq+1 - - ! Verify choice of advection schema - IF (hadv(iq)==vadv(iq)) THEN - iadv(new_iq)=hadv(iq) - ELSE IF (hadv(iq)==10 .AND. vadv(iq)==16) THEN - iadv(new_iq)=11 - ELSE - WRITE(lunout,*)trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq) - - CALL abort_gcm('infotrac_init','Bad choice of advection schema - 2',1) - END IF - - str1=tnom_0(iq) - tname(new_iq)= tnom_0(iq) - IF (iadv(new_iq)==0) THEN - ttext(new_iq)=trim(str1) - ELSE - ttext(new_iq)=trim(tnom_0(iq))//descrq(iadv(new_iq)) - END IF - - ! schemas tenant compte des moments d'ordre superieur - str2=ttext(new_iq) - IF (iadv(new_iq)==20) THEN - DO jq=1,3 - new_iq=new_iq+1 - iadv(new_iq)=-20 - ttext(new_iq)=trim(str2)//txts(jq) - tname(new_iq)=trim(str1)//txts(jq) - END DO - ELSE IF (iadv(new_iq)==30) THEN - DO jq=1,9 - new_iq=new_iq+1 - iadv(new_iq)=-30 - ttext(new_iq)=trim(str2)//txtp(jq) - tname(new_iq)=trim(str1)//txtp(jq) - END DO - END IF - END DO - -! -! Find vector keeping the correspodence between true and total tracers -! - niadv(:)=0 - iiq=0 - DO iq=1,nqtot - IF(iadv(iq).GE.0) THEN - ! True tracer - iiq=iiq+1 - niadv(iiq)=iq - ENDIF - END DO - - - WRITE(lunout,*) trim(modname),': Information stored in infotrac :' - WRITE(lunout,*) trim(modname),': iadv niadv tname ttext :' - DO iq=1,nqtot - WRITE(lunout,*) iadv(iq),niadv(iq),& - ' ',trim(tname(iq)),' ',trim(ttext(iq)) - END DO - -! -! Test for advection schema. -! This version of LMDZ only garantees iadv=10 and iadv=14 (14 only for water vapour) . -! - DO iq=1,nqtot - IF (iadv(iq)/=10 .AND. iadv(iq)/=14 .AND. iadv(iq)/=0) THEN - WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' - CALL abort_gcm('infotrac_init','In this version only iadv=10 and iadv=14 is tested!',1) - ELSE IF (iadv(iq)==14 .AND. iq/=1) THEN - WRITE(lunout,*)trim(modname),'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' - CALL abort_gcm('infotrac_init','In this version iadv=14 is only permitted for water vapour!',1) - END IF - END DO - -!----------------------------------------------------------------------- -! Finalize : -! - DEALLOCATE(tnom_0, hadv, vadv) - DEALLOCATE(tracnam) - - END SUBROUTINE infotrac_init - -END MODULE infotrac Index: LMDZ5/trunk/libf/dyn3dmem/inigrads.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/inigrads.F (revision 1944) +++ (revision ) @@ -1,93 +1,0 @@ -! -! $Header$ -! - subroutine inigrads(if,im - s ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz - s ,dt,file,titlel) - - - implicit none - - integer if,im,jm,lm,i,j,l - real x(im),y(jm),z(lm),fx,fy,fz,dt - real xmin,xmax,ymin,ymax - - character(len=*),intent(in) :: file - character(len=*),intent(in) :: titlel - -#include "gradsdef.h" - -c data unit/66,32,34,36,38,40,42,44,46,48/ - integer nf - save nf - data nf/0/ - - unit(1)=66 - unit(2)=32 - unit(3)=34 - unit(4)=36 - unit(5)=38 - unit(6)=40 - unit(7)=42 - unit(8)=44 - unit(9)=46 - - if (if.le.nf) stop'verifier les appels a inigrads' - - print*,'Entree dans inigrads' - - nf=if - title(if)=titlel - ivar(if)=0 - - fichier(if)=trim(file) - - firsttime(if)=.true. - dtime(if)=dt - - iid(if)=1 - ifd(if)=im - imd(if)=im - do i=1,im - xd(i,if)=x(i)*fx - if(xd(i,if).lt.xmin) iid(if)=i+1 - if(xd(i,if).le.xmax) ifd(if)=i - enddo - print*,'On stoke du point ',iid(if),' a ',ifd(if),' en x' - - jid(if)=1 - jfd(if)=jm - jmd(if)=jm - do j=1,jm - yd(j,if)=y(j)*fy - if(yd(j,if).gt.ymax) jid(if)=j+1 - if(yd(j,if).ge.ymin) jfd(if)=j - enddo - print*,'On stoke du point ',jid(if),' a ',jfd(if),' en y' - - print*,'Open de dat' - print*,'file=',file - print*,'fichier(if)=',fichier(if) - - print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if)) - print*,trim(file)//'.dat' - - OPEN (unit(if)+1,FILE=trim(file)//'.dat' - s ,FORM='unformatted', - s ACCESS='direct' - s ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1)) - - print*,'Open de dat ok' - - lmd(if)=lm - do l=1,lm - zd(l,if)=z(l)*fz - enddo - - irec(if)=0 - - print*,if,imd(if),jmd(if),lmd(if) - print*,'if,imd(if),jmd(if),lmd(if)' - - return - end Index: LMDZ5/trunk/libf/dyn3dmem/iniprint.h =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/iniprint.h (revision 1944) +++ (revision ) @@ -1,11 +1,0 @@ -! -! $Header$ -! -! -! gestion des impressions de sorties et de débogage -! lunout: unité du fichier dans lequel se font les sorties -! (par defaut 6, la sortie standard) -! prt_level: niveau d'impression souhaité (0 = minimum) -! - INTEGER lunout, prt_level - COMMON /comprint/ lunout, prt_level Index: LMDZ5/trunk/libf/dyn3dmem/initial0.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/initial0.F (revision 1944) +++ (revision ) @@ -1,12 +1,0 @@ -! -! $Header$ -! - SUBROUTINE initial0(n,x) - IMPLICIT NONE - INTEGER n,i - REAL x(n) - DO 10 i=1,n - x(i)=0. -10 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/interpost.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/interpost.F (revision 1944) +++ (revision ) @@ -1,45 +1,0 @@ -! -! $Header$ -! - subroutine interpost(q,qppm) - - implicit none - - -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comvert.h" -#include "comgeom2.h" - -c Arguments - real q(iip1,jjp1,llm) - real qppm(iim,jjp1,llm) -c Local - integer l,i,j - -c RE-INVERSION DES NIVEAUX -c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport -c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface -c On passe donc des niveaux de Lin à ceux du LMDZ - - do l=1,llm - do j=1,jjp1 - do i=1,iim - q(i,j,l)=qppm(i,j,llm-l+1) - enddo - enddo - enddo - -c BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D - - do l=1,llm - do j=1,jjp1 - q(iip1,j,l)=q(1,j,l) - enddo - enddo - - - return - - end Index: LMDZ5/trunk/libf/dyn3dmem/invert_lat.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/invert_lat.F90 (revision 1944) +++ (revision ) @@ -1,21 +1,0 @@ - -SUBROUTINE invert_lat(xsize,ysize,vsize,field) - - IMPLICIT NONE - -! Input variables - INTEGER, INTENT(IN) :: xsize,ysize,vsize - REAL, DIMENSION (xsize,ysize,vsize), INTENT(INOUT) :: field -! Local variables - REAL, DIMENSION (xsize,ysize,vsize) :: f_aux - INTEGER :: l,j - - DO l=1,vsize - DO j=1,ysize - f_aux(:,j,l)=field(:,ysize+1-j,l) - END DO - END DO - - field=f_aux - - END SUBROUTINE invert_lat Index: LMDZ5/trunk/libf/dyn3dmem/laplacien.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/laplacien.F (revision 1944) +++ (revision ) @@ -1,40 +1,0 @@ -! -! $Header$ -! - SUBROUTINE laplacien ( klevel, teta, divgra ) -c -c P. Le Van -c -c ************************************************************ -c .... calcul de (div( grad )) de teta ..... -c ************************************************************ -c klevel et teta sont des arguments d'entree pour le s-prog -c divgra est un argument de sortie pour le s-prog -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - -c -c ......... variables en arguments .............. -c - INTEGER klevel - REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) -c -c ............ variables locales .............. -c - REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) -c ....................................................... - - -c - CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) - - CALL filtreg( divgra, jjp1, klevel, 2, 1, .TRUE., 1 ) - CALL grad ( klevel,divgra, ghx , ghy ) - CALL divergf ( klevel, ghx , ghy , divgra ) - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/laplacien_gam.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/laplacien_gam.F (revision 1944) +++ (revision ) @@ -1,53 +1,0 @@ -! -! $Header$ -! - SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam , - * unsapolnga, unsapolsga, teta, divgra ) - -c P. Le Van -c -c ************************************************************ -c -c .... calcul de (div( grad )) de teta ..... -c ************************************************************ -c klevel et teta sont des arguments d'entree pour le s-prog -c divgra est un argument de sortie pour le s-prog -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - -c -c ............ variables en arguments .......... -c - INTEGER klevel - REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) - REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1), - * unsapolnga, unsapolsga -c -c ........... variables locales ................. -c - REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) -c ...................................................... - -c -c -c ... cvuscugam = ( cvu/ cu ) ** (- gamdissip ) -c ... cuvscvgam = ( cuv/ cv ) ** (- gamdissip ) calcules dans inigeom .. -c ... unsairegam = 1. / aire ** (- gamdissip ) -c - - CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) -c - CALL grad ( klevel, divgra, ghx, ghy ) -c - CALL diverg_gam ( klevel, cuvsga, cvusga, unsaigam , - * unsapolnga, unsapolsga, ghx , ghy , divgra ) - -c - - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/laplacien_rot.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/laplacien_rot.F (revision 1944) +++ (revision ) @@ -1,39 +1,0 @@ -! -! $Header$ -! - SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy ) -c -c P. Le Van -c -c ************************************************************ -c ... calcul de ( rotat x nxgrad ) du rotationnel rotin . -c ************************************************************ -c -c klevel et rotin sont des arguments d'entree pour le s-prog -c rotout est un argument de sortie pour le s-prog -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - -c -c .......... variables en arguments ............. -c - INTEGER klevel - REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) -c -c .......... variables locales ................ -c - REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel) -c ........................................................ -c -c - CALL filtreg ( rotin , jjm, klevel, 2, 1, .FALSE., 1 ) - - CALL nxgrad ( klevel, rotin, ghx , ghy ) - CALL rotatf ( klevel, ghx , ghy , rotout ) -c - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/laplacien_rotgam.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/laplacien_rotgam.F (revision 1944) +++ (revision ) @@ -1,44 +1,0 @@ -! -! $Header$ -! - SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout ) -c -c P. Le Van -c -c ************************************************************ -c ... calcul de (rotat x nxgrad)_gam du rotationnel rotin .. -c ************************************************************ -c klevel et teta sont des arguments d'entree pour le s-prog -c divgra est un argument de sortie pour le s-prog -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - -c -c ............. variables en arguments ........... -c - INTEGER klevel - REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) -c -c ............ variables locales ............... -c - INTEGER l, ij - REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) -c ........................................................ -c -c - - CALL nxgrad_gam ( klevel, rotin, ghx , ghy ) - CALL rotat_nfil ( klevel, ghx , ghy , rotout ) -c - DO l = 1, klevel - DO ij = 1, ip1jm - rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij) - ENDDO - ENDDO - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/massbar.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/massbar.F (revision 1944) +++ (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: LMDZ5/trunk/libf/dyn3dmem/massbarxy.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/massbarxy.F (revision 1944) +++ (revision ) @@ -1,47 +1,0 @@ -! -! $Header$ -! - SUBROUTINE massbarxy( masse, massebxy ) -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 .. massebxy est un 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 ), massebxy( ip1jm,llm ) -c - - DO 100 l = 1 , llm -c - DO 5 ij = 1, ip1jm - 1 - massebxy( ij,l ) = masse( ij ,l ) * alpha2( ij ) + - + masse( ij+1 ,l ) * alpha3( ij+1 ) + - + masse( ij+iip1,l ) * alpha1( ij+iip1 ) + - + masse( ij+iip2,l ) * alpha4( ij+iip2 ) - 5 CONTINUE - -c .... correction pour massebxy( iip1,j ) ........ - -CDIR$ IVDEP - - DO 7 ij = iip1, ip1jm, iip1 - massebxy( ij,l ) = massebxy( ij - iim,l ) - 7 CONTINUE - -100 CONTINUE -c - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/massdair.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/massdair.F (revision 1944) +++ (revision ) @@ -1,109 +1,0 @@ -! -! $Header$ -! - SUBROUTINE massdair( p, masse ) -c -c ********************************************************************* -c .... Calcule la masse d'air dans chaque maille .... -c ********************************************************************* -c -c Auteurs : P. Le Van , Fr. Hourdin . -c .......... -c -c .. p est un argum. d'entree pour le s-pg ... -c .. masse est un argum.de sortie pour le s-pg ... -c -c .... p est defini aux interfaces des llm couches ..... -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comconst.h" -#include "comgeom.h" -c -c ..... arguments .... -c - REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm) - -c .... Variables locales ..... - - INTEGER l,ij - REAL massemoyn, massemoys - - REAL SSUM -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 - masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) ) - ENDDO -c - DO ij = 1, ip1jmp1,iip1 - masse(ij+ iim,l) = masse(ij,l) - ENDDO -c -c DO ij = 1, iim -c masse( ij ,l) = masse( ij ,l) * aire( ij ) -c masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) -c ENDDO -c massemoyn = SSUM(iim,masse( 1 ,l),1)/ apoln -c massemoys = SSUM(iim,masse(ip1jm+1,l),1)/ apols -c DO ij = 1, iip1 -c masse( ij ,l ) = massemoyn -c masse(ij+ip1jm,l ) = massemoys -c ENDDO - -100 CONTINUE -c - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/minmax.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/minmax.F (revision 1944) +++ (revision ) @@ -1,23 +1,0 @@ -! -! $Header$ -! - SUBROUTINE minmax(imax, xi, zmin, zmax ) -c -c P. Le Van - - INTEGER imax - REAL xi(imax) - REAL zmin,zmax - INTEGER i - - zmin = xi(1) - zmax = xi(1) - - DO i = 2, imax - zmin = MIN( zmin,xi(i) ) - zmax = MAX( zmax,xi(i) ) - ENDDO - - RETURN - END - Index: LMDZ5/trunk/libf/dyn3dmem/minmax2.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/minmax2.F (revision 1944) +++ (revision ) @@ -1,20 +1,0 @@ -! -! $Header$ -! - SUBROUTINE minmax2(imax, jmax, lmax, xi, zmin, zmax ) -c - INTEGER lmax,jmax,imax - REAL xi(imax*jmax*lmax) - REAL zmin,zmax - INTEGER i - - zmin = xi(1) - zmax = xi(1) - - DO i = 2, imax*jmax*lmax - zmin = MIN( zmin,xi(i) ) - zmax = MAX( zmax,xi(i) ) - ENDDO - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/nxgrad.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/nxgrad.F (revision 1944) +++ (revision ) @@ -1,48 +1,0 @@ -! -! $Header$ -! - SUBROUTINE nxgrad (klevel, rot, x, y ) -c -c P. Le Van -c -c ******************************************************************** -c calcul du gradient tourne de pi/2 du rotationnel du vect.v -c ******************************************************************** -c rot est un argument d'entree pour le s-prog -c x et y sont des arguments de sortie pour le s-prog -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - INTEGER klevel - REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) - INTEGER l,ij -c -c - DO 10 l = 1,klevel -c - DO 1 ij = 2, ip1jm - y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) - 1 CONTINUE -c -c ..... correction pour y ( 1,j,l ) ...... -c -c .... y(1,j,l)= y(iip1,j,l) .... -CDIR$ IVDEP - DO 2 ij = 1, ip1jm, iip1 - y( ij,l ) = y( ij +iim,l ) - 2 CONTINUE -c - DO 4 ij = iip2,ip1jm - x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) - 4 CONTINUE - DO 6 ij = 1,iip1 - x( ij ,l ) = 0. - x( ij +ip1jm,l ) = 0. - 6 CONTINUE -c - 10 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/nxgrad_gam.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/nxgrad_gam.F (revision 1944) +++ (revision ) @@ -1,47 +1,0 @@ -! -! $Header$ -! - SUBROUTINE nxgrad_gam( klevel, rot, x, y ) -c -c P. Le Van -c -c ******************************************************************** -c calcul du gradient tourne de pi/2 du rotationnel du vect.v -c ******************************************************************** -c rot est un argument d'entree pour le s-prog -c x et y sont des arguments de sortie pour le s-prog -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - INTEGER klevel - REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) - INTEGER l,ij -c - DO 10 l = 1,klevel -c - DO 1 ij = 2, ip1jm - y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) - 1 CONTINUE -c -c ..... correction pour y ( 1,j,l ) ...... -c -c .... y(1,j,l)= y(iip1,j,l) .... -CDIR$ IVDEP - DO 2 ij = 1, ip1jm, iip1 - y( ij,l ) = y( ij +iim,l ) - 2 CONTINUE -c - DO 4 ij = iip2,ip1jm - x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) - 4 CONTINUE - DO 6 ij = 1,iip1 - x( ij ,l ) = 0. - x( ij +ip1jm,l ) = 0. - 6 CONTINUE -c - 10 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/nxgradst.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/nxgradst.F (revision 1944) +++ (revision ) @@ -1,47 +1,0 @@ -! -! $Header$ -! - SUBROUTINE nxgradst (klevel,rot, x, y ) -c - IMPLICIT NONE -c Auteur : P. Le Van -c -c ******************************************************************** -c calcul du gradient tourne de pi/2 du rotationnel du vect.v -c ******************************************************************** -c rot est un argument d'entree pour le s-prog -c x et y sont des arguments de sortie pour le s-prog -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - - INTEGER klevel - REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) - INTEGER l,ij -c - DO 10 l = 1,klevel -c - DO 1 ij = 2, ip1jm - y(ij,l)=( rot(ij,l) - rot(ij-1,l)) - 1 CONTINUE -c -c ..... correction pour y ( 1,j,l ) ...... -c -c .... y(1,j,l)= y(iip1,j,l) .... - - DO 2 ij = 1, ip1jm, iip1 - y( ij,l ) = y( ij +iim,l ) - 2 CONTINUE -c - DO 4 ij = iip2,ip1jm - x(ij,l)= rot(ij,l)-rot(ij-iip1,l) - 4 CONTINUE - DO 6 ij = 1,iip1 - x( ij ,l ) = 0. - x( ij +ip1jm,l ) = 0. - 6 CONTINUE -c - 10 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/nxgraro2.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/nxgraro2.F (revision 1944) +++ (revision ) @@ -1,68 +1,0 @@ -! -! $Header$ -! - SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry ) -c -c P.Le Van . -c *********************************************************** -c lr -c calcul de ( nxgrad (rot) ) du vect. v .... -c -c xcov et ycov etant les compos. covariantes de v -c *********************************************************** -c xcov , ycov et lr sont des arguments d'entree pour le s-prog -c grx et gry sont des arguments de sortie pour le s-prog -c -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comdissipn.h" -c -c ...... variables en arguments ....... -c - INTEGER klevel - REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) - REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) -c -c ...... variables locales ........ -c - REAL rot(ip1jm,llm) , signe, nugradrs - INTEGER l,ij,iter,lr -c ........................................................ -c -c -c - signe = (-1.)**lr - nugradrs = signe * crot -c - CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 ) - CALL SCOPY ( ip1jm * klevel, ycov, 1, gry, 1 ) -c - CALL rotatf ( klevel, grx, gry, rot ) -c - CALL laplacien_rot ( klevel, rot, rot,grx,gry ) - -c -c ..... Iteration de l'operateur laplacien_rotgam ..... -c - DO iter = 1, lr -2 - CALL laplacien_rotgam ( klevel, rot, rot ) - ENDDO -c -c - CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1) - CALL nxgrad ( klevel, rot, grx, gry ) -c - DO l = 1, klevel - DO ij = 1, ip1jm - gry( ij,l ) = gry( ij,l ) * nugradrs - ENDDO - DO ij = 1, ip1jmp1 - grx( ij,l ) = grx( ij,l ) * nugradrs - ENDDO - ENDDO -c - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/nxgrarot.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/nxgrarot.F (revision 1944) +++ (revision ) @@ -1,55 +1,0 @@ -! -! $Header$ -! - SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry ) -c *********************************************************** -c -c Auteur : P.Le Van -c -c lr -c calcul de ( nXgrad (rot) ) du vect. v .... -c -c xcov et ycov etant les compos. covariantes de v -c *********************************************************** -c xcov , ycov et lr sont des arguments d'entree pour le s-prog -c grx et gry sont des arguments de sortie pour le s-prog -c -c - IMPLICIT NONE -c -c -#include "dimensions.h" -#include "paramet.h" -#include "comdissipn.h" -#include "logic.h" -c - INTEGER klevel - REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) - REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) -c - REAL rot(ip1jm,llm) - - INTEGER l,ij,iter,lr -c -c -c - CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 ) - CALL SCOPY ( ip1jm*klevel, ycov, 1, gry, 1 ) -c - DO 10 iter = 1,lr - CALL rotat (klevel,grx, gry, rot ) - CALL filtreg( rot, jjm, klevel, 2,1, .false.,2) - CALL nxgrad (klevel,rot, grx, gry ) -c - DO 5 l = 1, klevel - DO 2 ij = 1, ip1jm - gry( ij,l ) = - gry( ij,l ) * crot - 2 CONTINUE - DO 3 ij = 1, ip1jmp1 - grx( ij,l ) = - grx( ij,l ) * crot - 3 CONTINUE - 5 CONTINUE -c - 10 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/pbar.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/pbar.F (revision 1944) +++ (revision ) @@ -1,124 +1,0 @@ -! -! $Header$ -! - SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy ) - IMPLICIT NONE - -c======================================================================= -c -c Auteur: P. Le Van -c ------- -c -c Objet: -c ------ -c -c ********************************************************************** -c calcul des moyennes en x et en y de (pression au sol*aire variable) .. -c ********************************************************************* -c -c pext est un argum. d'entree pour le s-pg .. -c pbarx,pbary et pbarxy sont des argum. de sortie pour le s-pg .. -c -c Methode: -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 -c On a : -c -c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + -c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) -c localise au point ... U (i,j) ... -c -c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + -c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) -c localise au point ... V (i,j) ... -c -c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + -c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) -c localise au point ... Z (i,j) ... -c -c -c -c======================================================================= - - -#include "dimensions.h" -#include "paramet.h" - -#include "comgeom.h" - - REAL pext( ip1jmp1 ), pbarx ( ip1jmp1 ) - REAL pbary( ip1jm ), pbarxy( ip1jm ) - - INTEGER ij - - - - DO 1 ij = 1, ip1jmp1 - 1 - pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1) - 1 CONTINUE - -c .... correction pour pbarx( iip1,j) ..... - -c ... pbarx(iip1,j)= pbarx(1,j) ... -CDIR$ IVDEP - DO 2 ij = iip1, ip1jmp1, iip1 - pbarx( ij ) = pbarx( ij - iim ) - 2 CONTINUE - - - DO 3 ij = 1,ip1jm - pbary( ij ) = pext( ij ) * alpha2p3( ij ) + - * pext( ij+iip1 ) * alpha1p4( ij+iip1 ) - 3 CONTINUE - - - DO 5 ij = 1, ip1jm - 1 - pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + - * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) - 5 CONTINUE - - -c .... correction pour pbarxy( iip1,j ) ........ - -CDIR$ IVDEP - - DO 7 ij = iip1, ip1jm, iip1 - pbarxy( ij ) = pbarxy( ij - iim ) - 7 CONTINUE - - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/pression.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/pression.F (revision 1944) +++ (revision ) @@ -1,32 +1,0 @@ -! -! $Header$ -! - SUBROUTINE pression( ngrid, ap, bp, ps, p ) -c - -c Auteurs : P. Le Van , Fr.Hourdin . - -c ************************************************************************ -c Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du -c sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) -c couches , avec p(ij,llm +1) = 0. et p(ij,1) = ps(ij) . -c ************************************************************************ -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -c - INTEGER ngrid - INTEGER l,ij - - REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) - - DO l = 1, llmp1 - DO ij = 1, ngrid - p(ij,l) = ap(l) + bp(l) * ps(ij) - ENDDO - ENDDO - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/profvert.def =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/profvert.def (revision 1944) +++ (revision ) @@ -1,23 +1,0 @@ -! -! $Header$ -! -nom_courbes=F -titre=/home/hourdin/LMDZ4/libf/dyn3d -xinf=0. -xsup=669. -yinf=6.5 -ysup=10.5 -axtxtx=sols -axtxty=pressure (mb) -pathcham=. -lstyles=1 9999 -linewidth=.2 -lcolors=1 9999 -frwidth=.5 -repery0=T -txtheight=2.5 -freecoord=/d2/hourdin/Ames/saison.def - -determination du champ physique -xlength=195. -ylength=105. Index: LMDZ5/trunk/libf/dyn3dmem/psextbar.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/psextbar.F (revision 1944) +++ (revision ) @@ -1,107 +1,0 @@ -! -! $Header$ -! - SUBROUTINE psextbar ( ps, psexbarxy ) - IMPLICIT NONE - -c======================================================================= -c -c Auteur: P. Le Van -c ------- -c -c Objet: -c ------ -c -c ********************************************************************** -c calcul des moyennes en x et en y de (pression au sol*aire variable) .. -c ********************************************************************** -c -c ps est un argum. d'entree pour le s-pg .. -c psexbarxy est un argum. de sortie pour le s-pg .. -c -c Methode: -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 -c On a : -c -c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + -c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) -c localise au point ... U (i,j) ... -c -c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + -c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) -c localise au point ... V (i,j) ... -c -c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + -c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) -c localise au point ... Z (i,j) ... -c -c -c -c======================================================================= - - -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" - - REAL ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 ) - - INTEGER l, ij -c - - DO ij = 1, ip1jmp1 - pext(ij) = ps(ij) * aire(ij) - ENDDO - - - DO 5 ij = 1, ip1jm - 1 - psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + - * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) - 5 CONTINUE - - -c .... correction pour psexbarxy( iip1,j ) ........ - -CDIR$ IVDEP - - DO 7 ij = iip1, ip1jm, iip1 - psexbarxy( ij ) = psexbarxy( ij - iim ) - 7 CONTINUE - - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/q_sat.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/q_sat.F (revision 1944) +++ (revision ) @@ -1,72 +1,0 @@ -! -! $Header$ -! -c -c - - subroutine q_sat(np,temp,pres,qsat) -c - IMPLICIT none -c====================================================================== -c Autheur(s): Z.X. Li (LMD/CNRS) -c reecriture vectorisee par F. Hourdin. -c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.) -c====================================================================== -c Arguments: -c kelvin---input-R: temperature en Kelvin -c millibar--input-R: pression en mb -c -c q_sat----output-R: vapeur d'eau saturante en kg/kg -c====================================================================== -c - integer np - REAL temp(np),pres(np),qsat(np) -c - REAL r2es - PARAMETER (r2es=611.14 *18.0153/28.9644) -c - REAL r3les, r3ies, r3es - PARAMETER (R3LES=17.269) - PARAMETER (R3IES=21.875) -c - REAL r4les, r4ies, r4es - PARAMETER (R4LES=35.86) - PARAMETER (R4IES=7.66) -c - REAL rtt - PARAMETER (rtt=273.16) -c - REAL retv - PARAMETER (retv=28.9644/18.0153 - 1.0) - - real zqsat - integer ip -c -C ------------------------------------------------------------------ -c -c - - do ip=1,np - -c write(*,*)'kelvin,millibar=',kelvin,millibar -c write(*,*)'temp,pres=',temp(ip),pres(ip) -c - IF (temp(ip) .LE. rtt) THEN - r3es = r3ies - r4es = r4ies - ELSE - r3es = r3les - r4es = r4les - ENDIF -c - zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es)) - zqsat=MIN(0.5,ZQSAT) - zqsat=zqsat/(1.-retv *zqsat) -c - qsat(ip)= zqsat -c write(*,*)'qsat=',qsat(ip) - - enddo -c - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/rotat.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/rotat.F (revision 1944) +++ (revision ) @@ -1,58 +1,0 @@ -! -! $Header$ -! - SUBROUTINE rotat (klevel, x, y, rot ) -c -c Auteur : P.Le Van -c************************************************************** -c. calcule le rotationnel -c a tous les niveaux d'1 vecteur de comp. x et y .. -c x et y etant des composantes covariantes ... -c******************************************************************** -c klevel, x et y sont des arguments d'entree pour le s-prog -c rot est un argument de sortie pour le s-prog -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" -c -c ..... variables en arguments ...... -c - INTEGER klevel - REAL rot( ip1jm,klevel ) - REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) -c -c ... variables locales ... -c - INTEGER l, ij -c -c - DO 10 l = 1,klevel -c - DO ij = 1, ip1jm - 1 - rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + - * x(ij +iip1, l ) - x( ij,l ) - ENDDO -c -c .... correction pour rot( iip1,j,l) .... -c .... rot(iip1,j,l)= rot(1,j,l) ... -CDIR$ IVDEP - DO ij = iip1, ip1jm, iip1 - rot( ij,l ) = rot( ij -iim,l ) - ENDDO -c - 10 CONTINUE - -ccc CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) - - DO l = 1, klevel - DO ij = 1, ip1jm - rot(ij,l) = rot(ij,l) * unsairez(ij) - ENDDO - ENDDO -c -c - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/rotat_nfil.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/rotat_nfil.F (revision 1944) +++ (revision ) @@ -1,49 +1,0 @@ -! -! $Header$ -! - SUBROUTINE rotat_nfil (klevel, x, y, rot ) -c -c Auteur : P.Le Van -c************************************************************** -c. Calcule le rotationnel non filtre , -c a tous les niveaux d'1 vecteur de comp. x et y .. -c x et y etant des composantes covariantes ... -c******************************************************************** -c klevel, x et y sont des arguments d'entree pour le s-prog -c rot est un argument de sortie pour le s-prog -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" -c -c ..... variables en arguments ...... -c - INTEGER klevel - REAL rot( ip1jm,klevel ) - REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) -c -c ... variables locales ... -c - INTEGER l, ij -c -c - DO 10 l = 1,klevel -c - DO ij = 1, ip1jm - 1 - rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + - * x(ij +iip1, l ) - x( ij,l ) - ENDDO -c -c .... correction pour rot( iip1,j,l) .... -c .... rot(iip1,j,l)= rot(1,j,l) ... -CDIR$ IVDEP - DO ij = iip1, ip1jm, iip1 - rot( ij,l ) = rot( ij -iim,l ) - ENDDO -c - 10 CONTINUE - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/rotatf.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/rotatf.F (revision 1944) +++ (revision ) @@ -1,58 +1,0 @@ -! -! $Header$ -! - SUBROUTINE rotatf (klevel, x, y, rot ) -c -c Auteur : P.Le Van -c************************************************************** -c. calcule le rotationnel -c a tous les niveaux d'1 vecteur de comp. x et y .. -c x et y etant des composantes covariantes ... -c******************************************************************** -c klevel, x et y sont des arguments d'entree pour le s-prog -c rot est un argument de sortie pour le s-prog -c - IMPLICIT NONE -c -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" -c -c ..... variables en arguments ...... -c - INTEGER klevel - REAL rot( ip1jm,klevel ) - REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) -c -c ... variables locales ... -c - INTEGER l, ij -c -c - DO 10 l = 1,klevel -c - DO ij = 1, ip1jm - 1 - rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + - * x(ij +iip1, l ) - x( ij,l ) - ENDDO -c -c .... correction pour rot( iip1,j,l) .... -c .... rot(iip1,j,l)= rot(1,j,l) ... -CDIR$ IVDEP - DO ij = iip1, ip1jm, iip1 - rot( ij,l ) = rot( ij -iim,l ) - ENDDO -c - 10 CONTINUE - - CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) - - DO l = 1, klevel - DO ij = 1, ip1jm - rot(ij,l) = rot(ij,l) * unsairez(ij) - ENDDO - ENDDO -c -c - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/rotatst.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/rotatst.F (revision 1944) +++ (revision ) @@ -1,43 +1,0 @@ -! -! $Header$ -! - SUBROUTINE rotatst (klevel,x, y, rot ) -c -c P. Le Van -c -c ***************************************************************** -c .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y .. -c x et y etant des composantes covariantes ..... -c ***************************************************************** -c x et y sont des arguments d'entree pour le s-prog -c rot est un argument de sortie pour le s-prog -c - IMPLICIT NONE -c - INTEGER klevel -#include "dimensions.h" -#include "paramet.h" - - REAL rot( ip1jm,klevel ) - REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) - INTEGER l, ij -c -c - DO 5 l = 1,klevel -c - DO 1 ij = 1, ip1jm - 1 - rot( ij,l ) = ( y( ij+1 , l ) - y( ij,l ) + - * x(ij +iip1, l ) - x( ij,l ) ) - 1 CONTINUE -c -c .... correction pour rot( iip1,j,l) .... -c -c .... rot(iip1,j,l)= rot(1,j,l) ... -CDIR$ IVDEP - DO 2 ij = iip1, ip1jm, iip1 - rot( ij,l ) = rot( ij -iim,l ) - 2 CONTINUE -c - 5 CONTINUE - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/serre.h =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/serre.h (revision 1944) +++ (revision ) @@ -1,11 +1,0 @@ -! -! $Header$ -! -!c -!c -!c..include serre.h -!c - REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo, & - & grossismx, grossismy, dzoomx, dzoomy,taux,tauy - COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , & - & grossismx, grossismy, dzoomx, dzoomy,taux,tauy Index: LMDZ5/trunk/libf/dyn3dmem/sort.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/sort.F (revision 1944) +++ (revision ) @@ -1,37 +1,0 @@ -! -! $Header$ -! -C -C - SUBROUTINE sort(n,d) -c -c P.Le Van -c -c... cette routine met le tableau d dans l'ordre croissant .... -cc ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc -c tion situee + bas IF(d(j).LE.p) THEN par -c IF(d(j).GE.p) THEN -c - - INTEGER n - REAL d(n) , p - INTEGER i,j,k - - DO i=1,n-1 - k=i - p=d(i) - DO j=i+1,n - IF(d(j).LE.p) THEN - k=j - p=d(j) - ENDIF - ENDDO - - IF(k.ne.i) THEN - d(k)=d(i) - d(i)=p - ENDIF - ENDDO - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/tourabs.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/tourabs.F (revision 1944) +++ (revision ) @@ -1,98 +1,0 @@ - SUBROUTINE tourabs ( ntetaSTD,vcov, ucov, vorabs ) - IMPLICIT NONE - -c======================================================================= -c -c Modif: I. Musat (28/10/04) -c ------- -c adaptation du code tourpot.F pour le calcul de la vorticite absolue -c cf. P. Le Van -c -c Objet: -c ------ -c -c ******************************************************************* -c ............. calcul de la vorticite absolue ................. -c ******************************************************************* -c -c ntetaSTD, vcov,ucov sont des argum. d'entree pour le s-pg . -c vorabs est un argum.de sortie pour le s-pg . -c -c======================================================================= - -#include "dimensions.h" -#include "paramet.h" -#include "comgeom.h" -#include "logic.h" -#include "comconst.h" -c - INTEGER ntetaSTD - REAL vcov( ip1jm,ntetaSTD ), ucov( ip1jmp1,ntetaSTD ) - REAL vorabs( ip1jm,ntetaSTD ) -c -c variables locales - INTEGER l, ij, i, j - REAL rot( ip1jm,ntetaSTD ) - - - -c ... vorabs = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) .. - - - -c ........ Calcul du rotationnel du vent V puis filtrage ........ - - DO 5 l = 1,ntetaSTD - - DO 2 i = 1, iip1 - DO 2 j = 1, jjm -c - ij=i+(j-1)*iip1 - IF(ij.LE.ip1jm - 1) THEN -c - IF(cv(ij).EQ.0..OR.cv(ij+1).EQ.0..OR. - $ cu(ij).EQ.0..OR.cu(ij+iip1).EQ.0.) THEN - rot( ij,l ) = 0. - continue - ELSE - rot( ij,l ) = (vcov(ij+1,l)/cv(ij+1)-vcov(ij,l)/cv(ij))/ - $ (2.*pi*RAD*cos(rlatv(j)))*REAL(iim) - $ +(ucov(ij+iip1,l)/cu(ij+iip1)-ucov(ij,l)/cu(ij))/ - $ (pi*RAD)*(REAL(jjm)-1.) -c - ENDIF - ENDIF !(ij.LE.ip1jm - 1) THEN - 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, ntetaSTD, 2, 1, .FALSE., 1 ) - - - DO 10 l = 1, ntetaSTD - - DO 6 ij = 1, ip1jm - 1 - vorabs( ij,l ) = ( rot(ij,l) + fext(ij)*unsairez(ij) ) - 6 CONTINUE - -c ..... correction pour vorabs( iip1,j,l) ..... -c .... vorabs(iip1,j,l)= vorabs(1,j,l) .... -CDIR$ IVDEP - DO 8 ij = iip1, ip1jm, iip1 - vorabs( ij,l ) = vorabs( ij -iim,l ) - 8 CONTINUE - - 10 CONTINUE - - RETURN - END Index: LMDZ5/trunk/libf/dyn3dmem/tourpot.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/tourpot.F (revision 1944) +++ (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: LMDZ5/trunk/libf/dyn3dmem/tracstoke.h =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/tracstoke.h (revision 1944) +++ (revision ) @@ -1,5 +1,0 @@ -! -! $Header$ -! - common /tracstoke/istdyn,istphy,unittrac - integer istdyn,istphy,unittrac Index: LMDZ5/trunk/libf/dyn3dmem/vitvert.F =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/vitvert.F (revision 1944) +++ (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: LMDZ5/trunk/libf/dyn3dmem/write_grads_dyn.h =================================================================== --- LMDZ5/trunk/libf/dyn3dmem/write_grads_dyn.h (revision 1944) +++ (revision ) @@ -1,31 +1,0 @@ -! -! $Header$ -! - if (callinigrads) then - - string10='dyn' - call inigrads(1,iip1 - s ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi - s ,llm,presnivs,1. - s ,dtvr*iperiod,string10,'dyn_zon ') - - callinigrads=.false. - - - endif - - string10='ps' - CALL wrgrads(1,1,ps,string10,string10) - - string10='u' - CALL wrgrads(1,llm,unat,string10,string10) - string10='v' - CALL wrgrads(1,llm,vnat,string10,string10) - string10='teta' - CALL wrgrads(1,llm,teta,string10,string10) - do iq=1,nqtot - string10='q' - write(string10(2:2),'(i1)') iq - CALL wrgrads(1,llm,q(:,:,iq),string10,string10) - enddo -