Index: LMDZ5/trunk/libf/dyn3d_common/academic.h =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/academic.h (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/academic.h (revision 1952) @@ -0,0 +1,9 @@ +! +! $Id$ +! + common/academic/tetarappel,knewt_t,kfrict,knewt_g,clat4 + real :: tetarappel(ip1jmp1,llm) + real :: knewt_t(llm) + real :: kfrict(llm) + real :: knewt_g + real :: clat4(ip1jmp1) Index: LMDZ5/trunk/libf/dyn3d_common/adaptdt.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/adaptdt.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/adaptdt.F (revision 1952) @@ -0,0 +1,59 @@ +! +! $Id$ +! + subroutine adaptdt(nadv,dtbon,n,pbaru, + c masse) + + USE control_mod + IMPLICIT NONE + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" + +c---------------------------------------------------------- +c Arguments +c---------------------------------------------------------- + INTEGER n,nadv + REAL dtbon + REAL pbaru(iip1,jjp1,llm) + REAL masse(iip1,jjp1,llm) +c---------------------------------------------------------- +c Local +c---------------------------------------------------------- + INTEGER i,j,l + REAL CFLmax,aaa,bbb + + CFLmax=0. + do l=1,llm + do j=2,jjm + do i=1,iim + aaa=pbaru(i,j,l)*dtvr/masse(i,j,l) + CFLmax=max(CFLmax,aaa) + bbb=-pbaru(i,j,l)*dtvr/masse(i+1,j,l) + CFLmax=max(CFLmax,bbb) + enddo + enddo + enddo + n=int(CFLmax)+1 +c pour reproduire cas VL du code qui appele x,y,z,y,x +c if (nadv.eq.30) n=n/2 ! Pour Prather + dtbon=dtvr/n + + return + end + + + + + + + Index: LMDZ5/trunk/libf/dyn3d_common/advx.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/advx.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/advx.F (revision 1952) @@ -0,0 +1,499 @@ +! +! $Header$ +! + SUBROUTINE advx(limit,dtx,pbaru,sm,s0, + $ sx,sy,sz,lati,latf) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (FOM) advection of tracer in X direction C +C C +C Source : Pascal Simon (Meteo,CNRM) C +C Adaptation : A.Armengaud (LGGE) juin 94 C +C C +C limit,dtx,pbaru,pbarv,sm,s0,sx,sy,sz C +C sont des arguments d'entree pour le s-pg... C +C C +C sm,s0,sx,sy,sz C +C sont les arguments de sortie pour le s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + +C Arguments : +C ----------- +C dtx : frequence fictive d'appel du transport +C pbaru, pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER ntra + PARAMETER (ntra = 1) + +C ATTENTION partout ou on trouve ntra, insertion de boucle +C possible dans l'avenir. + + REAL dtx + REAL pbaru ( iip1,jjp1,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) + REAL 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 UGRI(iip1,jjp1,llm) + +C Rem : VGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en x uniquement ) +C +C Ti 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 TEMPTM ! just a temporary variable +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) +C +C work arrays +C + REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) +C + REAL SMNEW(iim),UEXT(iim) +C + REAL sqi,sqf + + LOGICAL LIMIT + INTEGER NUM(jjp1),LONK,NUMK + INTEGER lon,lati,latf,niv + INTEGER i,i2,i3,j,jv,l,k,itrac + + lon = iim + niv = llm + +C *** Test de passage d'arguments ****** + + +C ------------------------------------- + DO 300 j = 1,jjp1 + NUM(j) = 1 + 300 CONTINUE + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim +cIM 240305 sqi = sqi + S0(i,j,l,9) + sqi = sqi + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVX - ENTREE ---------' + PRINT*,'sqi=',sqi + + +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,jjm+1 + DO 500 i = 1,iip1 +C ugri (i,j,llm+1-l) = pbaru (i,j,l) * ( dsig(l) / g ) + ugri (i,j,llm+1-l) = pbaru (i,j,l) + 500 CONTINUE + + +C --------------------------------------------------------- +C --------------------------------------------------------- +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. + 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) + 113 CONTINUE +C + DO JV=1,NTRA + DO 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) + TX(I,JV)=ALF(I) *sx(I3,K,L,JV)+ + $ ALF1(I)*TX(I,JV) +3.*TEMPTM + TY(I,JV)=TY(I,JV)+sy(I3,K,L,JV) + TZ(I,JV)=TZ(I,JV)+sz(I3,K,L,JV) + ENDDO + ENDDO +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)=sx(I,K,L,JV) + TY(I,JV)=sy(I,K,L,JV) + TZ(I,JV)=sz(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 + TX(I,JV)=SIGN(AMIN1(AMAX1(T0(I,JV),0.),ABS(TX(I,JV))),TX(I,JV)) + 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) + 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) ) + FX(I,JV)=ALFQ(I)*TX(I+1,JV) + FY(I,JV)=ALF (I)*TY(I+1,JV) + FZ(I,JV)=ALF (I)*TZ(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) + TY(I+1,JV)=TY(I+1,JV)-FY(I,JV) + TZ(I+1,JV)=TZ(I+1,JV)-FZ(I,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) ) + FX (I,JV)=ALFQ(I)*TX(1,JV) + FY (I,JV)=ALF (I)*TY(1,JV) + FZ (I,JV)=ALF (I)*TZ(1,JV) +C + T0(1,JV)=T0(1,JV)-F0(I,JV) + TX(1,JV)=ALF1Q(I)*TX(1,JV) + TY(1,JV)=TY(1,JV)-FY(I,JV) + TZ(1,JV)=TZ(1,JV)-FZ(I,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) ) + FX(I,JV)=ALFQ(I)*TX(I,JV) + FY(I,JV)=ALF (I)*TY(I,JV) + FZ(I,JV)=ALF (I)*TZ(I,JV) +C + T0(I,JV)=T0(I,JV)-F0(I,JV) + TX(I,JV)=ALF1Q(I)*TX(I,JV) + TY(I,JV)=TY(I,JV)-FY(I,JV) + TZ(I,JV)=TZ(I,JV)-FZ(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) + 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) + TX(I,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM + TY(I,JV)=TY(I,JV)+FY(I,JV) + TZ(I,JV)=TZ(I,JV)+FZ(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) + TX(I+1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(I+1,JV)+3.*TEMPTM + TY(I+1,JV)=TY(I+1,JV)+FY(I,JV) + TZ(I+1,JV)=TZ(I+1,JV)+FZ(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) + TX(1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM + TY(1,JV)=TY(1,JV)+FY(I,JV) + TZ(1,JV)=TZ(1,JV)+FZ(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 180 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) +C + 180 CONTINUE +C + DO JV=1,NTRA + DO I=1,LONK +C + I3=I2+(I-1)*NUMK + S0(I3,K,L,JV)=ALF (I) + $ * (T0(I,JV)-ALF1(I)*TX(I,JV)) + sx(I3,K,L,JV)=ALFQ(I)*TX(I,JV) + sy(I3,K,L,JV)=ALF (I)*TY(I,JV) + sz(I3,K,L,JV)=ALF (I)*TZ(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) + TY(I,JV)=TY(I,JV)-sy(I3,K,L,JV) + TZ(I,JV)=TZ(I,JV)-sz(I3,K,L,JV) + ENDDO + ENDDO +C +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) + sx(I,K,L,JV)=TX(I,JV) + sy(I,K,L,JV)=TY(I,JV) + sz(I,K,L,JV)=TZ(I,JV) + 1910 CONTINUE + 191 CONTINUE +C + ENDIF +C + 1 CONTINUE +C +C ----------- AA Test en fin de ADVX ------ Controle des S* +c OK +c DO 9998 l = 1, llm +c DO 9998 j = 1, jjp1 +c DO 9998 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVX' +c PRINT*,'SM(',i,j,l,')=',SM(i,j,l) +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(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 ADVX1' +cc STOP +c ENDIF +c 9998 CONTINUE +c +C ---------- bouclage cyclique + DO itrac=1,ntra + DO l = 1,llm + DO j = lati,latf + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,itrac) = S0(1,j,l,itrac) + sx(iip1,j,l,itrac) = sx(1,j,l,itrac) + sy(iip1,j,l,itrac) = sy(1,j,l,itrac) + sz(iip1,j,l,itrac) = sz(1,j,l,itrac) + END DO + END DO + ENDDO + +c ----------- qqtite totale de traceur dans tte l'atmosphere + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim +cIM 240405 sqf = sqf + S0(i,j,l,9) + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO +c + PRINT*,'------ DIAG DANS ADVX - SORTIE -----' + PRINT*,'sqf=',sqf +c------------- + + RETURN + END +C_________________________________________________________________ +C_________________________________________________________________ Index: LMDZ5/trunk/libf/dyn3d_common/advz.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/advz.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/advz.F (revision 1952) @@ -0,0 +1,322 @@ +! +! $Header$ +! + SUBROUTINE advz(limit,dtz,w,sm,s0,sx,sy,sz) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (FOM) advection of tracer in Z direction C +C C +C Source : Pascal Simon (Meteo,CNRM) C +C Adaptation : A.Armengaud (LGGE) juin 94 C +C C +C C +C sont des arguments d'entree pour le s-pg... C +C C +C dq est l'argument de sortie pour le s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + +C #include "traceur.h" + +C Arguments : +C ----------- +C dtz : frequence fictive d'appel du transport +C w : flux de masse en z en Pa.m2.s-1 + + INTEGER ntra + PARAMETER (ntra = 1) + + REAL dtz + REAL w ( iip1,jjp1,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 WGRI(iip1,jjp1,0:llm) + +C +C the moments F are used as temporary storage for +C portions of grid boxes in transit at the current latitude +C + REAL FM(iim,llm) + REAL F0(iim,llm,ntra),FX(iim,llm,ntra) + REAL FY(iim,llm,ntra),FZ(iim,llm,ntra) +C +C work arrays +C + REAL ALF(iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) + REAL TEMPTM ! Just temporal variable + REAL sqi,sqf +C + LOGICAL LIMIT + INTEGER lon,lat,niv + INTEGER i,j,jv,k,l,lp + + lon = iim + lat = jjp1 + 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*, 'sx(',i,j,l,')=',sx(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 ADVZ - pbl arg. passage dans ADVZ' +c STOP +c ENDIF + 399 CONTINUE + +C----------------------------------------------------------------- +C *** Test : diag de la qqtite totale de traceur +C dans l'atmosphere avant l'advection en z + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim +cIM 240305 sqi = sqi + S0(i,j,l,9) + sqi = sqi + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - ENTREE ---------' + PRINT*,'sqi=',sqi + +C----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion du flux de masse en kg.s-1 + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 +c wgri (i,j,llm+1-l) = w (i,j,l) / g + wgri (i,j,llm+1-l) = w (i,j,l) +c wgri (i,j,0) = 0. ! a detruire ult. +c wgri (i,j,l) = 0.1 ! w (i,j,l) +c wgri (i,j,llm) = 0. ! a detruire ult. + 500 CONTINUE + DO j = 1,jjp1 + DO i = 1,iip1 + wgri(i,j,0)=0. + enddo + enddo + +C----------------------------------------------------------------- + +C start here +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 + sz(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), + + ABS(sz(I,K,L,JV))),sz(I,K,L,JV)) + 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) +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) ) + FZ(I,L,JV)=ALFQ(I)*sz(I,K,LP,JV) + FX(I,L,JV)=ALF (I)*sx(I,K,LP,JV) + FY(I,L,JV)=ALF (I)*sy(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) + sx(I,K,LP,JV)=sx(I,K,LP,JV)-FX(I,L,JV) + sy(I,K,LP,JV)=sy(I,K,LP,JV)-FY(I,L,JV) +C + ELSE +C + F0(I,L,JV)=ALF (I)*(S0(I,K,L,JV)+ALF1(I)*sz(I,K,L,JV) ) + FZ(I,L,JV)=ALFQ(I)*sz(I,K,L,JV) + FX(I,L,JV)=ALF (I)*sx(I,K,L,JV) + FY(I,L,JV)=ALF (I)*sy(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) + sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,L,JV) + sy(I,K,L,JV)=sy(I,K,L,JV)-FY(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) +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) + sz(I,K,L,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,L,JV)+3.*TEMPTM + sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,L,JV) + sy(I,K,L,JV)=sy(I,K,L,JV)+FY(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) + sz(I,K,LP,JV)=ALF(I)*FZ(I,L,JV)+ALF1(I)*sz(I,K,LP,JV) + + +3.*TEMPTM + sx(I,K,LP,JV)=sx(I,K,LP,JV)+FX(I,L,JV) + sy(I,K,LP,JV)=sy(I,K,LP,JV)+FY(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 +C------------------------------------------------------------- +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 ADVZ' +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'sx(',i,j,l,')=',sx(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 ADVZ1' +c STOP +c ENDIF + 9999 CONTINUE + +C *** ------------------- bouclage cyclique en X ------------ + +c DO l = 1,llm +c DO j = 1,jjp1 +c SM(iip1,j,l) = SM(1,j,l) +c S0(iip1,j,l,ntra) = S0(1,j,l,ntra) +C sx(iip1,j,l,ntra) = sx(1,j,l,ntra) +c sy(iip1,j,l,ntra) = sy(1,j,l,ntra) +c sz(iip1,j,l,ntra) = sz(1,j,l,ntra) +c ENDDO +c ENDDO + +C------------------------------------------------------------- +C *** Test : diag de la qqtite totale de traceur +C dans l'atmosphere avant l'advection en z + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim +cIM 240305 sqf = sqf + S0(i,j,l,9) + sqf = sqf + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' + PRINT*,'sqf=', sqf + +C------------------------------------------------------------- + RETURN + END +C_______________________________________________________________ +C_______________________________________________________________ Index: LMDZ5/trunk/libf/dyn3d_common/comconst.h =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/comconst.h (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/comconst.h (revision 1952) @@ -0,0 +1,42 @@ +! +! $Id$ +! +!----------------------------------------------------------------------- +! INCLUDE comconst.h + + COMMON/comconsti/im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl, & + & iflag_top_bound,mode_top_bound + COMMON/comconstr/dtvr,daysec, & + & pi,dtphys,dtdiss,rad,r,cpp,kappa,cotot,unsim,g,omeg & + & ,dissip_factz,dissip_deltaz,dissip_zref & + & ,tau_top_bound, & + & daylen,year_day,molmass, ihf + + + INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl + REAL dtvr ! dynamical time step (in s) + REAL daysec !length (in s) of a standard day + REAL pi ! something like 3.14159.... + REAL dtphys ! (s) time step for the physics + REAL dtdiss ! (s) time step for the dissipation + REAL rad ! (m) radius of the planet + REAL r ! Reduced Gas constant r=R/mu + ! with R=8.31.. J.K-1.mol-1, mu: mol mass of atmosphere (kg/mol) + REAL cpp ! Specific heat Cp (J.kg-1.K-1) + REAL kappa ! kappa=R/Cp + REAL cotot + REAL unsim ! = 1./iim + REAL g ! (m/s2) gravity + REAL omeg ! (rad/s) rotation rate of the planet + REAL dissip_factz,dissip_deltaz,dissip_zref +! top_bound sponge: + INTEGER iflag_top_bound ! sponge type + INTEGER mode_top_bound ! sponge mode + REAL tau_top_bound ! inverse of sponge characteristic time scale (Hz) + REAL daylen ! length of solar day, in 'standard' day length + REAL year_day ! Number of standard days in a year + REAL molmass ! (g/mol) molar mass of the atmosphere + + REAL ihf ! (W/m2) Intrinsic heat flux (for giant planets) + +!----------------------------------------------------------------------- Index: LMDZ5/trunk/libf/dyn3d_common/comdissipn.h =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/comdissipn.h (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/comdissipn.h (revision 1952) @@ -0,0 +1,20 @@ +! +! $Header$ +! +! Attention : ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +!----------------------------------------------------------------------- +! INCLUDE comdissipn.h + + REAL tetaudiv, tetaurot, tetah, cdivu, crot, cdivh +! + COMMON/comdissipn/ tetaudiv(llm),tetaurot(llm),tetah(llm) , & + & cdivu, crot, cdivh + +! +! Les parametres de ce common proviennent des calculs effectues dans +! Inidissip . +! +!----------------------------------------------------------------------- Index: LMDZ5/trunk/libf/dyn3d_common/comdissnew.h =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/comdissnew.h (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/comdissnew.h (revision 1952) @@ -0,0 +1,30 @@ +! +! $Id$ +! +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +!----------------------------------------------------------------------- +! INCLUDE 'comdissnew.h' + + COMMON/comdissnew/ lstardis,nitergdiv,nitergrot,niterh,tetagdiv, & + & tetagrot,tetatemp,coefdis, vert_prof_dissip + + LOGICAL lstardis + INTEGER nitergdiv, nitergrot, niterh + + integer vert_prof_dissip ! vertical profile of horizontal dissipation +! Allowed values: +! 0: rational fraction, function of pressure +! 1: tanh of altitude + + REAL tetagdiv, tetagrot, tetatemp, coefdis + +! +! ... Les parametres de ce common comdissnew sont lues par defrun_new +! sur le fichier run.def .... +! +!----------------------------------------------------------------------- Index: LMDZ5/trunk/libf/dyn3d_common/comvert.h =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/comvert.h (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/comvert.h (revision 1952) @@ -0,0 +1,38 @@ +! +! $Id$ +! +!----------------------------------------------------------------------- +! INCLUDE 'comvert.h' + + COMMON/comvertr/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm), & + & pa,preff,nivsigs(llm),nivsig(llm+1), & + & aps(llm),bps(llm),scaleheight,pseudoalt(llm) + + common/comverti/disvert_type, pressure_exner + + real ap ! hybrid pressure contribution at interlayers + real bp ! hybrid sigma contribution at interlayer + real presnivs ! (reference) pressure at mid-layers + real dpres + real pa ! reference pressure (Pa) at which hybrid coordinates + ! become purely pressure + real preff ! reference surface pressure (Pa) + real nivsigs + real nivsig + real aps ! hybrid pressure contribution at mid-layers + real bps ! hybrid sigma contribution at mid-layers + real scaleheight ! atmospheric (reference) scale height (km) + real pseudoalt ! pseudo-altitude of model levels (km), based on presnivs(), + ! preff and scaleheight + + integer disvert_type ! type of vertical discretization: + ! 1: Earth (default for planet_type==earth), + ! automatic generation + ! 2: Planets (default for planet_type!=earth), + ! using 'z2sig.def' (or 'esasig.def) file + + logical pressure_exner +! compute pressure inside layers using Exner function, else use mean +! of pressure values at interfaces + + !----------------------------------------------------------------------- Index: LMDZ5/trunk/libf/dyn3d_common/control_mod.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/control_mod.F90 (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/control_mod.F90 (revision 1952) @@ -0,0 +1,27 @@ +! +! $Id $ +! + +MODULE control_mod + +! LF 01/2010 +! Remplacement du fichier et common control + + IMPLICIT NONE + + REAL :: periodav, starttime + INTEGER :: nday,day_step,iperiod,iapp_tracvl,nsplit_phys + INTEGER :: iconser,iecri,dissip_period,iphysiq,iecrimoy + INTEGER :: dayref,anneeref, raz_date, ip_ebil_dyn + LOGICAL :: offline + CHARACTER (len=4) :: config_inca + CHARACTER (len=10) :: planet_type ! planet type ('earth','mars',...) + LOGICAL output_grads_dyn ! output dynamics diagnostics in + ! binary grads file 'dyn.dat' (y/n) + LOGICAL ok_dynzon ! output zonal transports in dynzon.nc file + LOGICAL ok_dyn_ins ! output instantaneous values of fields + ! in the dynamics in NetCDF files dyn_hist*nc + LOGICAL ok_dyn_ave ! output averaged values of fields in the dynamics + ! in NetCDF files dyn_hist*ave.nc + +END MODULE Index: LMDZ5/trunk/libf/dyn3d_common/description.h =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/description.h (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/description.h (revision 1952) @@ -0,0 +1,5 @@ +! +! $Header$ +! + character (len=120) :: descript + common /titre/descript Index: LMDZ5/trunk/libf/dyn3d_common/diagedyn.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/diagedyn.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/diagedyn.F (revision 1952) @@ -0,0 +1,321 @@ +! +! $Id$ +! + +C====================================================================== + SUBROUTINE diagedyn(tit,iprt,idiag,idiag2,dtime + e , ucov , vcov , ps, p ,pk , teta , q, ql) +C====================================================================== +C +C Purpose: +C Calcul la difference d'enthalpie et de masse d'eau entre 2 appels, +C et calcul le flux de chaleur et le flux d'eau necessaire a ces +C changements. Ces valeurs sont moyennees sur la surface de tout +C le globe et sont exprime en W/2 et kg/s/m2 +C Outil pour diagnostiquer la conservation de l'energie +C et de la masse dans la dynamique. +C +C +c====================================================================== +C Arguments: +C tit-----imput-A15- Comment added in PRINT (CHARACTER*15) +C iprt----input-I- PRINT level ( <=1 : no PRINT) +C idiag---input-I- indice dans lequel sera range les nouveaux +C bilans d' entalpie et de masse +C idiag2--input-I-les nouveaux bilans d'entalpie et de masse +C sont compare au bilan de d'enthalpie de masse de +C l'indice numero idiag2 +C Cas parriculier : si idiag2=0, pas de comparaison, on +c sort directement les bilans d'enthalpie et de masse +C dtime----input-R- time step (s) +C uconv, vconv-input-R- vents covariants (m/s) +C ps-------input-R- Surface pressure (Pa) +C p--------input-R- pressure at the interfaces +C pk-------input-R- pk= (p/Pref)**kappa +c teta-----input-R- potential temperature (K) +c q--------input-R- vapeur d'eau (kg/kg) +c ql-------input-R- liquid watter (kg/kg) +c aire-----input-R- mesh surafce (m2) +c +C the following total value are computed by UNIT of earth surface +C +C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy +c change (J/m2) during one time step (dtime) for the whole +C atmosphere (air, watter vapour, liquid and solid) +C d_qt------output-R- total water mass flux (kg/m2/s) defined as the +C total watter (kg/m2) change during one time step (dtime), +C d_qw------output-R- same, for the watter vapour only (kg/m2/s) +C d_ql------output-R- same, for the liquid watter only (kg/m2/s) +C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column +C +C +C J.L. Dufresne, July 2002 +c====================================================================== + + IMPLICIT NONE +C +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" + +#ifdef CPP_EARTH +#include "../phylmd/YOMCST.h" +#include "../phylmd/YOETHF.h" +#endif +C + INTEGER imjmp1 + PARAMETER( imjmp1=iim*jjp1) +c Input variables + CHARACTER*15 tit + INTEGER iprt,idiag, idiag2 + REAL dtime + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL ps(ip1jmp1) ! pression au sol + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pk (ip1jmp1,llm ) ! = (p/Pref)**kappa + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm) ! champs eau vapeur + REAL ql(ip1jmp1,llm) ! champs eau liquide + + +c Output variables + REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec +C +C Local variables +c + REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot + . , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot +c h_vcol_tot-- total enthalpy of vertical air column +C (air with watter vapour, liquid and solid) (J/m2) +c h_dair_tot-- total enthalpy of dry air (J/m2) +c h_qw_tot---- total enthalpy of watter vapour (J/m2) +c h_ql_tot---- total enthalpy of liquid watter (J/m2) +c h_qs_tot---- total enthalpy of solid watter (J/m2) +c qw_tot------ total mass of watter vapour (kg/m2) +c ql_tot------ total mass of liquid watter (kg/m2) +c qs_tot------ total mass of solid watter (kg/m2) +c ec_tot------ total cinetic energy (kg/m2) +C + REAL masse(ip1jmp1,llm) ! masse d'air + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL ecin(ip1jmp1,llm) + + REAL zaire(imjmp1) + REAL zps(imjmp1) + REAL zairm(imjmp1,llm) + REAL zecin(imjmp1,llm) + REAL zpaprs(imjmp1,llm) + REAL zpk(imjmp1,llm) + REAL zt(imjmp1,llm) + REAL zh(imjmp1,llm) + REAL zqw(imjmp1,llm) + REAL zql(imjmp1,llm) + REAL zqs(imjmp1,llm) + + REAL zqw_col(imjmp1) + REAL zql_col(imjmp1) + REAL zqs_col(imjmp1) + REAL zec_col(imjmp1) + REAL zh_dair_col(imjmp1) + REAL zh_qw_col(imjmp1), zh_ql_col(imjmp1), zh_qs_col(imjmp1) +C + REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs +C + REAL airetot, zcpvap, zcwat, zcice +C + INTEGER i, k, jj, ij , l ,ip1jjm1 +C + INTEGER ndiag ! max number of diagnostic in parallel + PARAMETER (ndiag=10) + integer pas(ndiag) + save pas + data pas/ndiag*0/ +C + REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag) + $ , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag) + $ , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag) + SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre + $ , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre + + +#ifdef CPP_EARTH +c====================================================================== +C Compute Kinetic enrgy + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL massdair( p, masse ) +c====================================================================== +C +C + print*,'MAIS POURQUOI DONC DIAGEDYN NE MARCHE PAS ?' + return +C On ne garde les donnees que dans les colonnes i=1,iim + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zaire(i)=aire(ij+ip1jjm1) + zps(i)=ps(ij+ip1jjm1) + ENDDO + ENDDO +C 3D arrays + DO l = 1, llm + DO jj = 1,jjp1 + ip1jjm1=iip1*(jj-1) + DO ij = 1,iim + i=iim*(jj-1)+ij + zairm(i,l) = masse(ij+ip1jjm1,l) + zecin(i,l) = ecin(ij+ip1jjm1,l) + zpaprs(i,l) = p(ij+ip1jjm1,l) + zpk(i,l) = pk(ij+ip1jjm1,l) + zh(i,l) = teta(ij+ip1jjm1,l) + zqw(i,l) = q(ij+ip1jjm1,l) + zql(i,l) = ql(ij+ip1jjm1,l) + zqs(i,l) = 0. + ENDDO + ENDDO + ENDDO +C +C Reset variables + DO i = 1, imjmp1 + zqw_col(i)=0. + zql_col(i)=0. + zqs_col(i)=0. + zec_col(i) = 0. + zh_dair_col(i) = 0. + zh_qw_col(i) = 0. + zh_ql_col(i) = 0. + zh_qs_col(i) = 0. + ENDDO +C + zcpvap=RCPV + zcwat=RCW + zcice=RCS +C +C Compute vertical sum for each atmospheric column +C ================================================ + DO k = 1, llm + DO i = 1, imjmp1 +C Watter mass + zqw_col(i) = zqw_col(i) + zqw(i,k)*zairm(i,k) + zql_col(i) = zql_col(i) + zql(i,k)*zairm(i,k) + zqs_col(i) = zqs_col(i) + zqs(i,k)*zairm(i,k) +C Cinetic Energy + zec_col(i) = zec_col(i) + $ +zecin(i,k)*zairm(i,k) +C Air enthalpy + zt(i,k)= zh(i,k) * zpk(i,k) / RCPD + zh_dair_col(i) = zh_dair_col(i) + $ + RCPD*(1.-zqw(i,k)-zql(i,k)-zqs(i,k))*zairm(i,k)*zt(i,k) + zh_qw_col(i) = zh_qw_col(i) + $ + zcpvap*zqw(i,k)*zairm(i,k)*zt(i,k) + zh_ql_col(i) = zh_ql_col(i) + $ + zcwat*zql(i,k)*zairm(i,k)*zt(i,k) + $ - RLVTT*zql(i,k)*zairm(i,k) + zh_qs_col(i) = zh_qs_col(i) + $ + zcice*zqs(i,k)*zairm(i,k)*zt(i,k) + $ - RLSTT*zqs(i,k)*zairm(i,k) + + END DO + ENDDO +C +C Mean over the planete surface +C ============================= + qw_tot = 0. + ql_tot = 0. + qs_tot = 0. + ec_tot = 0. + h_vcol_tot = 0. + h_dair_tot = 0. + h_qw_tot = 0. + h_ql_tot = 0. + h_qs_tot = 0. + airetot=0. +C + do i=1,imjmp1 + qw_tot = qw_tot + zqw_col(i) + ql_tot = ql_tot + zql_col(i) + qs_tot = qs_tot + zqs_col(i) + ec_tot = ec_tot + zec_col(i) + h_dair_tot = h_dair_tot + zh_dair_col(i) + h_qw_tot = h_qw_tot + zh_qw_col(i) + h_ql_tot = h_ql_tot + zh_ql_col(i) + h_qs_tot = h_qs_tot + zh_qs_col(i) + airetot=airetot+zaire(i) + END DO +C + qw_tot = qw_tot/airetot + ql_tot = ql_tot/airetot + qs_tot = qs_tot/airetot + ec_tot = ec_tot/airetot + h_dair_tot = h_dair_tot/airetot + h_qw_tot = h_qw_tot/airetot + h_ql_tot = h_ql_tot/airetot + h_qs_tot = h_qs_tot/airetot +C + h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot +C +C Compute the change of the atmospheric state compare to the one +C stored in "idiag2", and convert it in flux. THis computation +C is performed IF idiag2 /= 0 and IF it is not the first CALL +c for "idiag" +C =================================== +C + IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN + d_h_vcol = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime + d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime + d_h_qw = (h_qw_tot - h_qw_pre(idiag2) )/dtime + d_h_ql = (h_ql_tot - h_ql_pre(idiag2) )/dtime + d_h_qs = (h_qs_tot - h_qs_pre(idiag2) )/dtime + d_qw = (qw_tot - qw_pre(idiag2) )/dtime + d_ql = (ql_tot - ql_pre(idiag2) )/dtime + d_qs = (qs_tot - qs_pre(idiag2) )/dtime + d_ec = (ec_tot - ec_pre(idiag2) )/dtime + d_qt = d_qw + d_ql + d_qs + ELSE + d_h_vcol = 0. + d_h_dair = 0. + d_h_qw = 0. + d_h_ql = 0. + d_h_qs = 0. + d_qw = 0. + d_ql = 0. + d_qs = 0. + d_ec = 0. + d_qt = 0. + ENDIF +C + IF (iprt.ge.2) THEN + WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs + 9000 format('Dyn3d. Watter Mass Budget (kg/m2/s)',A15 + $ ,1i6,10(1pE14.6)) + WRITE(6,9001) tit,pas(idiag), d_h_vcol + 9001 format('Dyn3d. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2)) + WRITE(6,9002) tit,pas(idiag), d_ec + 9002 format('Dyn3d. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2)) +C WRITE(6,9003) tit,pas(idiag), ec_tot + 9003 format('Dyn3d. Cinetic Energy (W/m2) ',A15,1i6,10(E15.6)) + WRITE(6,9004) tit,pas(idiag), d_h_vcol+d_ec + 9004 format('Dyn3d. Total Energy Budget (W/m2) ',A15,1i6,10(F8.2)) + END IF +C +C Store the new atmospheric state in "idiag" +C + pas(idiag)=pas(idiag)+1 + h_vcol_pre(idiag) = h_vcol_tot + h_dair_pre(idiag) = h_dair_tot + h_qw_pre(idiag) = h_qw_tot + h_ql_pre(idiag) = h_ql_tot + h_qs_pre(idiag) = h_qs_tot + qw_pre(idiag) = qw_tot + ql_pre(idiag) = ql_tot + qs_pre(idiag) = qs_tot + ec_pre (idiag) = ec_tot +C +#else + write(lunout,*)'diagedyn: Needs Earth physics to function' +#endif +! #endif of #ifdef CPP_EARTH + RETURN + END Index: LMDZ5/trunk/libf/dyn3d_common/disvert.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/disvert.F90 (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/disvert.F90 (revision 1952) @@ -0,0 +1,180 @@ +! $Id$ + +SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig,scaleheight) + + ! Auteur : P. Le Van + + use new_unit_m, only: new_unit + use ioipsl, only: getin + use assert_m, only: assert + + IMPLICIT NONE + + include "dimensions.h" + include "paramet.h" + include "iniprint.h" + include "logic.h" + + ! s = sigma ** kappa : coordonnee verticale + ! dsig(l) : epaisseur de la couche l ds la coord. s + ! sig(l) : sigma a l'interface des couches l et l-1 + ! ds(l) : distance entre les couches l et l-1 en coord.s + + real,intent(in) :: pa, preff + real,intent(out) :: ap(llmp1) ! in Pa + real, intent(out):: bp(llmp1) + real,intent(out) :: dpres(llm), nivsigs(llm), nivsig(llmp1) + real,intent(out) :: presnivs(llm) + real,intent(out) :: scaleheight + + REAL sig(llm+1), dsig(llm) + real zk, zkm1, dzk1, dzk2, k0, k1 + + INTEGER l, unit + REAL dsigmin + REAL alpha, beta, deltaz + REAL x + character(len=*),parameter :: modname="disvert" + + character(len=6):: vert_sampling + ! (allowed values are "param", "tropo", "strato" and "read") + + !----------------------------------------------------------------------- + + print *, "Call sequence information: disvert" + + ! default scaleheight is 8km for earth + scaleheight=8. + + vert_sampling = merge("strato", "tropo ", ok_strato) ! default value + call getin('vert_sampling', vert_sampling) + print *, 'vert_sampling = ' // vert_sampling + + select case (vert_sampling) + case ("param") + ! On lit les options dans sigma.def: + OPEN(99, file='sigma.def', status='old', form='formatted') + READ(99, *) scaleheight ! hauteur d'echelle 8. + READ(99, *) deltaz ! epaiseur de la premiere couche 0.04 + READ(99, *) beta ! facteur d'acroissement en haut 1.3 + READ(99, *) k0 ! nombre de couches dans la transition surf + READ(99, *) k1 ! nombre de couches dans la transition haute + CLOSE(99) + alpha=deltaz/(llm*scaleheight) + write(lunout, *)trim(modname),':scaleheight, alpha, k0, k1, beta', & + scaleheight, alpha, k0, k1, beta + + alpha=deltaz/tanh(1./k0)*2. + zkm1=0. + sig(1)=1. + do l=1, llm + sig(l+1)=(cosh(l/k0))**(-alpha*k0/scaleheight) & + *exp(-alpha/scaleheight*tanh((llm-k1)/k0) & + *beta**(l-(llm-k1))/log(beta)) + zk=-scaleheight*log(sig(l+1)) + + dzk1=alpha*tanh(l/k0) + dzk2=alpha*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta) + write(lunout, *)l, sig(l+1), zk, zk-zkm1, dzk1, dzk2 + zkm1=zk + enddo + + sig(llm+1)=0. + + bp(: llm) = EXP(1. - 1. / sig(: llm)**2) + bp(llmp1) = 0. + + ap = pa * (sig - bp) + case("tropo") + DO l = 1, llm + x = 2*asin(1.) * (l - 0.5) / (llm + 1) + dsig(l) = 1.0 + 7.0 * SIN(x)**2 + ENDDO + dsig = dsig / sum(dsig) + sig(llm+1) = 0. + DO l = llm, 1, -1 + sig(l) = sig(l+1) + dsig(l) + ENDDO + + bp(1)=1. + bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2) + bp(llmp1) = 0. + + ap(1)=0. + ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1)) + case("strato") + if (llm==39) then + dsigmin=0.3 + else if (llm==50) then + dsigmin=1. + else + write(lunout,*) trim(modname), ' ATTENTION discretisation z a ajuster' + dsigmin=1. + endif + WRITE(LUNOUT,*) trim(modname), 'Discretisation verticale DSIGMIN=',dsigmin + + DO l = 1, llm + x = 2*asin(1.) * (l - 0.5) / (llm + 1) + dsig(l) =(dsigmin + 7. * SIN(x)**2) & + *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2 + ENDDO + dsig = dsig / sum(dsig) + sig(llm+1) = 0. + DO l = llm, 1, -1 + sig(l) = sig(l+1) + dsig(l) + ENDDO + + bp(1)=1. + bp(2: llm) = EXP(1. - 1. / sig(2: llm)**2) + bp(llmp1) = 0. + + ap(1)=0. + ap(2: llm + 1) = pa * (sig(2: llm + 1) - bp(2: llm + 1)) + case("read") + ! Read "ap" and "bp". First line is skipped (title line). "ap" + ! should be in Pa. First couple of values should correspond to + ! the surface, that is : "bp" should be in descending order. + call new_unit(unit) + open(unit, file="hybrid.txt", status="old", action="read", & + position="rewind") + read(unit, fmt=*) ! skip title line + do l = 1, llm + 1 + read(unit, fmt=*) ap(l), bp(l) + end do + close(unit) + call assert(ap(1) == 0., ap(llm + 1) == 0., bp(1) == 1., & + bp(llm + 1) == 0., "disvert: bad ap or bp values") + case default + call abort_gcm("disvert", 'Wrong value for "vert_sampling"', 1) + END select + + DO l=1, llm + nivsigs(l) = REAL(l) + ENDDO + + DO l=1, llmp1 + nivsig(l)= REAL(l) + ENDDO + + write(lunout, *) trim(modname),': BP ' + write(lunout, *) bp + write(lunout, *) trim(modname),': AP ' + write(lunout, *) ap + + write(lunout, *) 'Niveaux de pressions approximatifs aux centres des' + write(lunout, *)'couches calcules pour une pression de surface =', preff + write(lunout, *) 'et altitudes equivalentes pour une hauteur d echelle de ' + write(lunout, *) scaleheight,' km' + DO l = 1, llm + dpres(l) = bp(l) - bp(l+1) + presnivs(l) = 0.5 *( ap(l)+bp(l)*preff + ap(l+1)+bp(l+1)*preff ) + write(lunout, *)'PRESNIVS(', l, ')=', presnivs(l), ' Z ~ ', & + log(preff/presnivs(l))*scaleheight & + , ' DZ ~ ', scaleheight*log((ap(l)+bp(l)*preff)/ & + max(ap(l+1)+bp(l+1)*preff, 1.e-10)) + ENDDO + + write(lunout, *) trim(modname),': PRESNIVS ' + write(lunout, *) presnivs + +END SUBROUTINE disvert Index: LMDZ5/trunk/libf/dyn3d_common/disvert_noterre.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/disvert_noterre.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/disvert_noterre.F (revision 1952) @@ -0,0 +1,330 @@ +! $Id: $ + SUBROUTINE disvert_noterre + +c Auteur : F. Forget Y. Wanherdrick, P. Levan +c Nouvelle version 100% Mars !! +c On l'utilise aussi pour Venus et Titan, legerment modifiee. + +#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 + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "comconst.h" +#include "logic.h" +#include "iniprint.h" +c +c======================================================================= +c Discretisation verticale en coordonnée hybride (ou sigma) +c +c======================================================================= +c +c declarations: +c ------------- +c +c + INTEGER l,ll + REAL snorm + REAL alpha,beta,gama,delta,deltaz + real quoi,quand + REAL zsig(llm),sig(llm+1) + INTEGER np,ierr + integer :: ierr1,ierr2,ierr3,ierr4 + REAL x + + REAL SSUM + EXTERNAL SSUM + real newsig + REAL dz0,dz1,nhaut,sig1,esig,csig,zz + real tt,rr,gg, prevz + real s(llm),dsig(llm) + + integer iz + real z, ps,p + character(len=*),parameter :: modname="disvert_noterre" + +c +c----------------------------------------------------------------------- +c +! Initializations: +! pi=2.*ASIN(1.) ! already done in iniconst + + hybrid=.true. ! default value for hybrid (ie: use hybrid coordinates) + CALL getin('hybrid',hybrid) + write(lunout,*) trim(modname),': hybrid=',hybrid + +! Ouverture possible de fichiers typiquement E.T. + + open(99,file="esasig.def",status='old',form='formatted', + s iostat=ierr2) + if(ierr2.ne.0) then + close(99) + open(99,file="z2sig.def",status='old',form='formatted', + s iostat=ierr4) + endif + +c----------------------------------------------------------------------- +c cas 1 on lit les options dans esasig.def: +c ---------------------------------------- + + IF(ierr2.eq.0) then + +c Lecture de esasig.def : +c Systeme peu souple, mais qui respecte en theorie +c La conservation de l'energie (conversion Energie potentielle +c <-> energie cinetique, d'apres la note de Frederic Hourdin... + + write(lunout,*)'*****************************' + write(lunout,*)'WARNING reading esasig.def' + write(lunout,*)'*****************************' + READ(99,*) scaleheight + READ(99,*) dz0 + READ(99,*) dz1 + READ(99,*) nhaut + CLOSE(99) + + dz0=dz0/scaleheight + dz1=dz1/scaleheight + + sig1=(1.-dz1)/tanh(.5*(llm-1)/nhaut) + + esig=1. + + do l=1,20 + esig=-log((1./sig1-1.)*exp(-dz0)/esig)/(llm-1.) + enddo + csig=(1./sig1-1.)/(exp(esig)-1.) + + DO L = 2, llm + zz=csig*(exp(esig*(l-1.))-1.) + sig(l) =1./(1.+zz) + & * tanh(.5*(llm+1-l)/nhaut) + ENDDO + sig(1)=1. + sig(llm+1)=0. + quoi = 1. + 2.* kappa + s( llm ) = 1. + s(llm-1) = quoi + IF( llm.gt.2 ) THEN + DO ll = 2, llm-1 + l = llm+1 - ll + quand = sig(l+1)/ sig(l) + s(l-1) = quoi * (1.-quand) * s(l) + quand * s(l+1) + ENDDO + END IF +c + snorm=(1.-.5*sig(2)+kappa*(1.-sig(2)))*s(1)+.5*sig(2)*s(2) + DO l = 1, llm + s(l) = s(l)/ snorm + ENDDO + +c----------------------------------------------------------------------- +c cas 2 on lit les options dans z2sig.def: +c ---------------------------------------- + + ELSE IF(ierr4.eq.0) then + write(lunout,*)'****************************' + write(lunout,*)'Reading z2sig.def' + write(lunout,*)'****************************' + + READ(99,*) scaleheight + do l=1,llm + read(99,*) zsig(l) + end do + CLOSE(99) + + sig(1) =1 + do l=2,llm + sig(l) = 0.5 * ( exp(-zsig(l)/scaleheight) + + & exp(-zsig(l-1)/scaleheight) ) + end do + sig(llm+1) =0 + +c----------------------------------------------------------------------- + ELSE + write(lunout,*) 'didn t you forget something ??? ' + write(lunout,*) 'We need file z2sig.def ! (OR esasig.def)' + stop + ENDIF +c----------------------------------------------------------------------- + + DO l=1,llm + nivsigs(l) = REAL(l) + ENDDO + + DO l=1,llmp1 + nivsig(l)= REAL(l) + ENDDO + + +c----------------------------------------------------------------------- +c .... Calculs de ap(l) et de bp(l) .... +c ......................................... +c +c ..... pa et preff sont lus sur les fichiers start par dynetat0 ..... +c----------------------------------------------------------------------- +c + + if (hybrid) then ! use hybrid coordinates + write(lunout,*) "*********************************" + write(lunout,*) "Using hybrid vertical coordinates" + write(lunout,*) +c Coordonnees hybrides avec mod + DO l = 1, llm + + call sig_hybrid(sig(l),pa,preff,newsig) + bp(l) = EXP( 1. - 1./(newsig**2) ) + ap(l) = pa * (newsig - bp(l) ) + enddo + bp(llmp1) = 0. + ap(llmp1) = 0. + else ! use sigma coordinates + write(lunout,*) "********************************" + write(lunout,*) "Using sigma vertical coordinates" + write(lunout,*) +c Pour ne pas passer en coordonnees hybrides + DO l = 1, llm + ap(l) = 0. + bp(l) = sig(l) + ENDDO + ap(llmp1) = 0. + endif + + bp(llmp1) = 0. + + write(lunout,*) trim(modname),': BP ' + write(lunout,*) bp + write(lunout,*) trim(modname),': AP ' + write(lunout,*) ap + +c Calcul au milieu des couches : +c WARNING : le choix de placer le milieu des couches au niveau de +c pression intermédiaire est arbitraire et pourrait etre modifié. +c Le calcul du niveau pour la derniere couche +c (on met la meme distance (en log pression) entre P(llm) +c et P(llm -1) qu'entre P(llm-1) et P(llm-2) ) est +c Specifique. Ce choix est spécifié ici ET dans exner_milieu.F + + DO l = 1, llm-1 + aps(l) = 0.5 *( ap(l) +ap(l+1)) + bps(l) = 0.5 *( bp(l) +bp(l+1)) + ENDDO + + if (hybrid) then + aps(llm) = aps(llm-1)**2 / aps(llm-2) + bps(llm) = 0.5*(bp(llm) + bp(llm+1)) + else + bps(llm) = bps(llm-1)**2 / bps(llm-2) + aps(llm) = 0. + end if + + write(lunout,*) trim(modname),': BPs ' + write(lunout,*) bps + write(lunout,*) trim(modname),': APs' + write(lunout,*) aps + + DO l = 1, llm + presnivs(l) = aps(l)+bps(l)*preff + pseudoalt(l) = -scaleheight*log(presnivs(l)/preff) + ENDDO + + write(lunout,*)trim(modname),' : PRESNIVS' + write(lunout,*)presnivs + write(lunout,*)'Pseudo altitude of Presnivs : (for a scale ', + & 'height of ',scaleheight,' km)' + write(lunout,*)pseudoalt + +c -------------------------------------------------- +c This can be used to plot the vertical discretization +c (> xmgrace -nxy testhybrid.tab ) +c -------------------------------------------------- +c open (53,file='testhybrid.tab') +c scaleheight=15.5 +c do iz=0,34 +c z = -5 + min(iz,34-iz) +c approximation of scale height for Venus +c scaleheight = 15.5 - z/55.*10. +c ps = preff*exp(-z/scaleheight) +c zsig(1)= -scaleheight*log((aps(1) + bps(1)*ps)/preff) +c do l=2,llm +c approximation of scale height for Venus +c if (zsig(l-1).le.55.) then +c scaleheight = 15.5 - zsig(l-1)/55.*10. +c else +c scaleheight = 5.5 - (zsig(l-1)-55.)/35.*2. +c endif +c zsig(l)= zsig(l-1)-scaleheight* +c . log((aps(l) + bps(l)*ps)/(aps(l-1) + bps(l-1)*ps)) +c end do +c write(53,'(I3,50F10.5)') iz, zsig +c end do +c close(53) +c -------------------------------------------------- + + + RETURN + END + +c ************************************************************ + subroutine sig_hybrid(sig,pa,preff,newsig) +c ---------------------------------------------- +c Subroutine utilisee pour calculer des valeurs de sigma modifie +c pour conserver les coordonnees verticales decrites dans +c esasig.def/z2sig.def lors du passage en coordonnees hybrides +c F. Forget 2002 +c Connaissant sig (niveaux "sigma" ou on veut mettre les couches) +c L'objectif est de calculer newsig telle que +c (1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig = sig +c Cela ne se résoud pas analytiquement: +c => on résoud par iterration bourrine +c ---------------------------------------------- +c Information : where exp(1-1./x**2) become << x +c x exp(1-1./x**2) /x +c 1 1 +c 0.68 0.5 +c 0.5 1.E-1 +c 0.391 1.E-2 +c 0.333 1.E-3 +c 0.295 1.E-4 +c 0.269 1.E-5 +c 0.248 1.E-6 +c => on peut utiliser newsig = sig*preff/pa si sig*preff/pa < 0.25 + + + implicit none + real x1, x2, sig,pa,preff, newsig, F + integer j + + newsig = sig + x1=0 + x2=1 + if (sig.ge.1) then + newsig= sig + else if (sig*preff/pa.ge.0.25) then + DO J=1,9999 ! nombre d''iteration max + F=((1 -pa/preff)*exp(1-1./newsig**2)+(pa/preff)*newsig)/sig +c write(0,*) J, ' newsig =', newsig, ' F= ', F + if (F.gt.1) then + X2 = newsig + newsig=(X1+newsig)*0.5 + else + X1 = newsig + newsig=(X2+newsig)*0.5 + end if +c Test : on arete lorsque on approxime sig à moins de 0.01 m près +c (en pseudo altitude) : + IF(abs(10.*log(F)).LT.1.E-5) goto 999 + END DO + else ! if (sig*preff/pa.le.0.25) then + newsig= sig*preff/pa + end if + 999 continue + Return + END Index: LMDZ5/trunk/libf/dyn3d_common/dump2d.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/dump2d.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/dump2d.F (revision 1952) @@ -0,0 +1,46 @@ +! +! $Id$ +! + SUBROUTINE dump2d(im,jm,z,nom_z) + IMPLICIT NONE + INTEGER im,jm + REAL z(im,jm) + CHARACTER (len=*) :: nom_z + + INTEGER i,j,imin,illm,jmin,jllm + REAL zmin,zllm + + WRITE(*,*) "dump2d: ",trim(nom_z) + + zmin=z(1,1) + zllm=z(1,1) + imin=1 + illm=1 + jmin=1 + jllm=1 + + DO j=1,jm + DO i=1,im + IF(z(i,j).GT.zllm) THEN + illm=i + jllm=j + zllm=z(i,j) + ENDIF + IF(z(i,j).LT.zmin) THEN + imin=i + jmin=j + zmin=z(i,j) + ENDIF + ENDDO + ENDDO + + PRINT*,'MIN: ',zmin + PRINT*,'MAX: ',zllm + + IF(zllm.GT.zmin) THEN + DO j=1,jm + WRITE(*,'(600i1)') (NINT(10.*(z(i,j)-zmin)/(zllm-zmin)),i=1,im) + ENDDO + ENDIF + RETURN + END Index: LMDZ5/trunk/libf/dyn3d_common/ener.h =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/ener.h (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/ener.h (revision 1952) @@ -0,0 +1,18 @@ +! +! $Id$ +! +! ATTENTION!!!!: ce fichier include est compatible format fixe/format libre +! veillez à n'utiliser que des ! pour les commentaires +! et à bien positionner les & des lignes de continuation +! (les placer en colonne 6 et en colonne 73) +! +! INCLUDE 'ener.h' + + COMMON/ener/ang0,etot0,ptot0,ztot0,stot0, & + & ang,etot,ptot,ztot,stot,rmsdpdt , & + & rmsv,gtot(llmm1) + + REAL ang0,etot0,ptot0,ztot0,stot0, & + & ang,etot,ptot,ztot,stot,rmsdpdt,rmsv,gtot + +!----------------------------------------------------------------------- Index: LMDZ5/trunk/libf/dyn3d_common/exner_hyb.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/exner_hyb.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/exner_hyb.F (revision 1952) @@ -0,0 +1,152 @@ +! +! $Id $ +! + SUBROUTINE exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf ) +c +c Auteurs : P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... alpha,beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * p ** 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 -------- z +c A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et +c ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) +c ( voir note de Fr.Hourdin ) , +c +c on determine successivement , du haut vers le bas des couches, les +c coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), +c puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, +c pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . +c +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), alpha(ngrid,llm),beta(ngrid,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL unpl2k,dellta + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM +c + logical,save :: firstcall=.true. + character(len=*),parameter :: modname="exner_hyb" + + ! 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) + + 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: + + unpl2k = 1.+ 2.* kappa +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 des coeff. alpha et beta pour la couche l = llm .. +c + DO ij = 1, ngrid + alpha(ij,llm) = 0. + beta (ij,llm) = 1./ unpl2k + ENDDO +c +c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... +c + DO l = llm -1 , 2 , -1 +c + DO ij = 1, ngrid + dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) + alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) + beta (ij,l) = p(ij,l ) / dellta + ENDDO +c + ENDDO +c +c *********************************************************************** +c ..... Calcul de pk pour la couche 1 , pres du sol .... +c + DO ij = 1, ngrid + pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / + * ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) + ENDDO +c +c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ +c + DO l = 2, llm + DO ij = 1, ngrid + pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) + ENDDO + ENDDO +c +c + CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) + + + RETURN + END Index: LMDZ5/trunk/libf/dyn3d_common/extrapol.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/extrapol.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/extrapol.F (revision 1952) @@ -0,0 +1,200 @@ +! +! $Id$ +! +C +C + SUBROUTINE extrapol (pfild, kxlon, kylat, pmask, + . norsud, ldper, knbor, pwork) + IMPLICIT none +c +c OASIS routine (Adaptation: Laurent Li, le 14 mars 1997) +c Fill up missed values by using the neighbor points +c + INTEGER kxlon, kylat ! longitude and latitude dimensions (Input) + INTEGER knbor ! minimum neighbor number (Input) + LOGICAL norsud ! True if field is from North to South (Input) + LOGICAL ldper ! True if take into account the periodicity (Input) + REAL pmask ! mask value (Input) + REAL pfild(kxlon,kylat) ! field to be extrapolated (Input/Output) + REAL pwork(kxlon,kylat) ! working space +c + REAL zwmsk + INTEGER incre, idoit, i, j, k, inbor, ideb, ifin, ilon, jlat + INTEGER ix(9), jy(9) ! index arrays for the neighbors coordinates + REAL zmask(9) +C +C We search over the eight closest neighbors +C +C j+1 7 8 9 +C j 4 5 6 Current point 5 --> (i,j) +C j-1 1 2 3 +C i-1 i i+1 +c +c + IF (norsud) THEN + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,kylat-j+1) + ENDDO + ENDDO + DO j = 1, kylat + DO i = 1, kxlon + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO + ENDIF +c + incre = 0 +c + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,j) + ENDDO + ENDDO +c +C* To avoid problems in floating point tests + zwmsk = pmask - 1.0 +c +200 CONTINUE + incre = incre + 1 + DO 99999 j = 1, kylat + DO 99999 i = 1, kxlon + IF (pfild(i,j).GT. zwmsk) THEN + pwork(i,j) = pfild(i,j) + inbor = 0 + ideb = 1 + ifin = 9 +C +C* Fill up ix array + ix(1) = MAX (1,i-1) + ix(2) = i + ix(3) = MIN (kxlon,i+1) + ix(4) = MAX (1,i-1) + ix(5) = i + ix(6) = MIN (kxlon,i+1) + ix(7) = MAX (1,i-1) + ix(8) = i + ix(9) = MIN (kxlon,i+1) +C +C* Fill up iy array + jy(1) = MAX (1,j-1) + jy(2) = MAX (1,j-1) + jy(3) = MAX (1,j-1) + jy(4) = j + jy(5) = j + jy(6) = j + jy(7) = MIN (kylat,j+1) + jy(8) = MIN (kylat,j+1) + jy(9) = MIN (kylat,j+1) +C +C* Correct latitude bounds if southernmost or northernmost points + IF (j .EQ. 1) ideb = 4 + IF (j .EQ. kylat) ifin = 6 +C +C* Account for periodicity in longitude +C + IF (ldper) THEN + IF (i .EQ. kxlon) THEN + ix(3) = 1 + ix(6) = 1 + ix(9) = 1 + ELSE IF (i .EQ. 1) THEN + ix(1) = kxlon + ix(4) = kxlon + ix(7) = kxlon + ENDIF + ELSE + IF (i .EQ. 1) THEN + ix(1) = i + ix(2) = i + 1 + ix(3) = i + ix(4) = i + 1 + ix(5) = i + ix(6) = i + 1 + ENDIF + IF (i .EQ. kxlon) THEN + ix(1) = i -1 + ix(2) = i + ix(3) = i - 1 + ix(4) = i + ix(5) = i - 1 + ix(6) = i + ENDIF +C + IF (i .EQ. 1 .OR. i .EQ. kxlon) THEN + jy(1) = MAX (1,j-1) + jy(2) = MAX (1,j-1) + jy(3) = j + jy(4) = j + jy(5) = MIN (kylat,j+1) + jy(6) = MIN (kylat,j+1) +C + ideb = 1 + ifin = 6 + IF (j .EQ. 1) ideb = 3 + IF (j .EQ. kylat) ifin = 4 + ENDIF + ENDIF ! end for ldper test +C +C* Find unmasked neighbors +C + DO 230 k = ideb, ifin + zmask(k) = 0. + ilon = ix(k) + jlat = jy(k) + IF (pfild(ilon,jlat) .LT. zwmsk) THEN + zmask(k) = 1. + inbor = inbor + 1 + ENDIF + 230 CONTINUE +C +C* Not enough points around point P are unmasked; interpolation on P +C will be done in a future call to extrap. +C + IF (inbor .GE. knbor) THEN + pwork(i,j) = 0. + DO k = ideb, ifin + ilon = ix(k) + jlat = jy(k) + pwork(i,j) = pwork(i,j) + $ + pfild(ilon,jlat) * zmask(k)/ REAL(inbor) + ENDDO + ENDIF +C + ENDIF +99999 CONTINUE +C +C* 3. Writing back unmasked field in pfild +C ------------------------------------ +C +C* pfild then contains: +C - Values which were not masked +C - Interpolated values from the inbor neighbors +C - Values which are not yet interpolated +C + idoit = 0 + DO j = 1, kylat + DO i = 1, kxlon + IF (pwork(i,j) .GT. zwmsk) idoit = idoit + 1 + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO +c + IF (idoit .ne. 0) GOTO 200 +ccc PRINT*, "Number of extrapolation steps incre =", incre +c + IF (norsud) THEN + DO j = 1, kylat + DO i = 1, kxlon + pwork(i,j) = pfild(i,kylat-j+1) + ENDDO + ENDDO + DO j = 1, kylat + DO i = 1, kxlon + pfild(i,j) = pwork(i,j) + ENDDO + ENDDO + ENDIF +c + RETURN + END Index: LMDZ5/trunk/libf/dyn3d_common/fxy.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/fxy.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/fxy.F (revision 1952) @@ -0,0 +1,69 @@ +! +! $Id$ +! + SUBROUTINE fxy (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + IMPLICIT NONE + +c Auteur : P. Le Van +c +c Calcul des longitudes et des latitudes pour une fonction f(x,y) +c a tangente sinusoidale et eventuellement avec zoom . +c +c +#include "dimensions.h" +#include "paramet.h" +#include "serre.h" +#include "comconst.h" + + INTEGER i,j + + 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) + +#include "fxy_new.h" + + +c ...... calcul des latitudes et de y' ..... +c + DO j = 1, jjm + 1 + rlatu(j) = fy ( REAL( j ) ) + yprimu(j) = fyprim( REAL( j ) ) + ENDDO + + + DO j = 1, jjm + + rlatv(j) = fy ( REAL( j ) + 0.5 ) + rlatu1(j) = fy ( REAL( j ) + 0.25 ) + rlatu2(j) = fy ( REAL( j ) + 0.75 ) + + yprimv(j) = fyprim( REAL( j ) + 0.5 ) + yprimu1(j) = fyprim( REAL( j ) + 0.25 ) + yprimu2(j) = fyprim( REAL( j ) + 0.75 ) + + ENDDO + +c +c ..... calcul des longitudes et de x' ..... +c + DO i = 1, iim + 1 + rlonv(i) = fx ( REAL( i ) ) + rlonu(i) = fx ( REAL( i ) + 0.5 ) + rlonm025(i) = fx ( REAL( i ) - 0.25 ) + rlonp025(i) = fx ( REAL( i ) + 0.25 ) + + xprimv (i) = fxprim ( REAL( i ) ) + xprimu (i) = fxprim ( REAL( i ) + 0.5 ) + xprimm025(i) = fxprim ( REAL( i ) - 0.25 ) + xprimp025(i) = fxprim ( REAL( i ) + 0.25 ) + ENDDO + +c + RETURN + END + Index: LMDZ5/trunk/libf/dyn3d_common/fxysinus.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/fxysinus.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/fxysinus.F (revision 1952) @@ -0,0 +1,69 @@ +! +! $Id$ +! + SUBROUTINE fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + + IMPLICIT NONE +c +c Calcul des longitudes et des latitudes pour une fonction f(x,y) +c avec y = Asin( j ) . +c +c Auteur : P. Le Van +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" + + INTEGER i,j + + 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) + +#include "fxy_sin.h" + + +c ...... calcul des latitudes et de y' ..... +c + DO j = 1, jjm + 1 + rlatu(j) = fy ( REAL( j ) ) + yprimu(j) = fyprim( REAL( j ) ) + ENDDO + + + DO j = 1, jjm + + rlatv(j) = fy ( REAL( j ) + 0.5 ) + rlatu1(j) = fy ( REAL( j ) + 0.25 ) + rlatu2(j) = fy ( REAL( j ) + 0.75 ) + + yprimv(j) = fyprim( REAL( j ) + 0.5 ) + yprimu1(j) = fyprim( REAL( j ) + 0.25 ) + yprimu2(j) = fyprim( REAL( j ) + 0.75 ) + + ENDDO + +c +c ..... calcul des longitudes et de x' ..... +c + DO i = 1, iim + 1 + rlonv(i) = fx ( REAL( i ) ) + rlonu(i) = fx ( REAL( i ) + 0.5 ) + rlonm025(i) = fx ( REAL( i ) - 0.25 ) + rlonp025(i) = fx ( REAL( i ) + 0.25 ) + + xprimv (i) = fxprim ( REAL( i ) ) + xprimu (i) = fxprim ( REAL( i ) + 0.5 ) + xprimm025(i) = fxprim ( REAL( i ) - 0.25 ) + xprimp025(i) = fxprim ( REAL( i ) + 0.25 ) + ENDDO + +c + RETURN + END + Index: LMDZ5/trunk/libf/dyn3d_common/grilles_gcm_netcdf.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/grilles_gcm_netcdf.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/grilles_gcm_netcdf.F (revision 1952) @@ -0,0 +1,305 @@ +! +! $Id$ +! +c +c + + PROGRAM create_fausse_var +C + IMPLICIT NONE +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" + + real temp(iim+1,jjm+1) +#include "netcdf.inc" + +c Attributs netcdf sortie + character*64 fich_out + integer*4 ncid_out,rcode_out + integer*4 out_lonuid,out_lonvid,out_latuid,out_latvid + integer*4 out_varid + integer*4 out_lonudim,out_lonvdim + integer*4 out_latudim,out_latvdim,out_dim(3) + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + integer start(4),count(4) + + integer status,i,j + real rlatudeg(jjp1),rlatvdeg(jjm) + real rlonudeg(iip1),rlonvdeg(iip1) + + real dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1) + real acoslat,dxkm,dykm,resol(iip1,jjp1) + +#include "serre.h" +#include "fxyprim.h" + + print*,'OK0' + + rad = 6400000 + omeg = 7.272205e-05 + g = 9.8 + kappa = 0.285716 + daysec = 86400 + cpp = 1004.70885 + + preff = 101325. + pa= 50000. + +c open(99,file='run.def',status='old',form='formatted') +c CALL defrun_new( 99, .TRUE.,clesphy0 ) +c close(99) + + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + CALL iniconst + CALL inigeom + + + print*,'OK1' + do j=1,jjp1 + rlatudeg(j)=rlatu(j)*180./pi + enddo + do j=1,jjm + rlatvdeg(j)=rlatv(j)*180./pi + enddo + + do i=1,iip1 + rlonudeg(i)=rlonu(i)*180./pi + 360. + rlonvdeg(i)=rlonv(i)*180./pi + 360. + enddo + + + print*,'OK2' +c 2 ----- OUVERTURE DE LA SORTIE NETCDF +c --------------------------------------------------- +c CREATION OUTPUT +c ouverture fichier netcdf de sortie out + fich_out='grilles_gcm.nc' + + status=NF_CREATE(fich_out,NF_NOCLOBBER,ncid_out) + status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim) + status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim) + status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim) + status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim) + + + print*,'OK3' +c Longitudes en u + print *,'OUTID: ',ncid_out + status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim, + % out_lonuid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units', + % 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name', + % 9,'Longitude en u') + +c Longitudes en v + print *,'OUTID: ',ncid_out + status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim, + % out_lonvid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units', + % 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name', + % 9,'Longitude en v') + +c Latitude en u + status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim, + % out_latuid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units', + % 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name', + % 8,'Latitude en u') + +c Latitude en v + status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim, + % out_latvid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units', + % 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name', + % 8,'Latitude en v') + +c ecriture de la grille u + out_dim(1)=out_lonudim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point u') + +c ecriture de la grille v + out_dim(1)=out_lonvdim + out_dim(2)=out_latvdim + status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point v') + +c ecriture de la grille u + out_dim(1)=out_lonvdim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim, + % out_varid) + call handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', + % 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', + % 16,'Grille aux point u') + + + print*,'OK4' + status=NF_ENDDEF(ncid_out) +c 5) ----- FERMETURE DES FICHIERS NETCDF------------------ +c -------------------------------------------------------- +c 3-b- Ecriture de la grille pour la sortie +c rajoute l'ecriture de la grille + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg) +#endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=1 + + count(1)=iim+1 + count(2)=jjm+1 + count(3)=1 + count(4)=1 + + do j=1,jjm+1 + do i=1,iim+1 + temp(i,j)=mod(i,2)+mod(j,2) + enddo + enddo + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start, + s count,temp) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_varid,start, + s count,temp) +#endif + + +c fermeture du fichier netcdf + call ncclos(ncid_out,rcode_out) + write(*,*) 'Fermeture: ',fich_out + + + print*,'OK5' +c Ecriture grads + open (20,file='grille.dat',form='unformatted',access='direct' + s ,recl=4*ip1jmp1) + write(20,rec=1) ((REAL(mod(i,2)+mod(j,2)),i=1,iip1),j=1,jjp1) + write(20,rec=2) ((REAL(mod(i,2)*mod(j,2)),i=1,iip1),j=1,jjp1) + do j=2,jjm + dlat1(j)=180.*(rlatv(j)-rlatv(j-1))/pi +c dlat2(j)=180.*fyprim(REAL(j))/pi + enddo + do i=2,iip1 + dlon1(i)=180.*(rlonu(i)-rlonu(i-1))/pi +c dlon2(i)=180.*fxprim(REAL(i))/pi + enddo + do j=2,jjm + dykm=(rlatv(j)-rlatv(j-1))*6400. + acoslat=6400.*cos(rlatu(j)) + do i=2,iip1 + dxkm=acoslat*(rlonu(i)-rlonu(i-1)) + resol(i,j)=sqrt(dykm*dykm+dxkm*dxkm) + enddo + resol(1,j)=resol(iip1,j) + enddo + write(20,rec=3) resol + dlon1(1)=dlon1(iip1) + dlon2(1)=dlon2(iip1) + write(20,rec=4) ((dlon1(i),i=1,iip1),j=1,jjp1) + write(20,rec=5) ((dlon1(i)*pi/180.*0.001* + s cos(rlatu(j))*rad,i=1,iip1),j=1,jjp1) + write(20,rec=6) ((dlon2(i),i=1,iip1),j=1,jjp1) + write(20,rec=7) ((dlat1(j),i=1,iip1),j=1,jjp1) + write(20,rec=8) ((dlat1(j)*pi/180.*rad*0.001,i=1,iip1),j=1,jjp1) + write(20,rec=9) ((dlat2(j),i=1,iip1),j=1,jjp1) + + print*,'I, LON, DX (km)' + do i=1,iip1 + print*,i,rlonu(i)*180./pi,dlon1(i)*pi/180.*0.001* + s cos(clat*pi/180.)*rad + enddo + print*,'J, LAT, DY (km)' + do j=1,jjp1 + print*,j,rlatu(j)*180./pi,dlat1(j)*pi/180.*0.001*rad + enddo + + open (21,file='grille.ctl',form='formatted') + +c WARNING! on reecrase le fichier .ctl a chaque ecriture + write(21,'(a5,1x,a40)') + & 'DSET ','^grille.dat' + + write(21,'(a12)') 'UNDEF 1.0E30' + write(21,'(a5,1x,a40)') 'TITLE ','grille' + call formcoord(21,iip1,rlonv,180./pi,.false.,'XDEF') + call formcoord(21,jjp1,rlatu,180./pi,.true.,'YDEF') + call formcoord(21,1,0.,1.,.false.,'ZDEF') + write(21,'(a4,i10,a30)') + & 'TDEF ',1,' LINEAR 23OCT1994 3hr ' + write(21,'(a4,2x,i5)') 'VARS',9 + write(21,'(a18)') 'grille 0 99 grille' + write(21,'(a18)') 'gril 0 99 gril ' + write(21,'(a29)') 'resol 0 99 resolution (km) ' + write(21,'(a18)') 'dlon1 0 99 dlon1 ' + write(21,'(a20)') 'dx 0 99 dx (km) ' + write(21,'(a18)') 'dlon2 0 99 dlon2 ' + write(21,'(a18)') 'dlat1 0 99 dlat1 ' + write(21,'(a20)') 'dy 0 99 dy (km) ' + write(21,'(a18)') 'dlat2 0 99 dlat2 ' + write(21,'(a7)') 'ENDVARS' + + + + + + print*,'OK6' + end + + + + subroutine handle_err(status) +#include "netcdf.inc" + + + integer status + print *,'handle code err: ',NF_NOERR + IF (status.NE.nf_noerr) THEN + print *,NF_STRERROR(status) + stop 'stopped' + ENDIF + END + Index: LMDZ5/trunk/libf/dyn3d_common/grilles_gcm_netcdf_sub.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/grilles_gcm_netcdf_sub.F90 (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/grilles_gcm_netcdf_sub.F90 (revision 1952) @@ -0,0 +1,237 @@ +! +! $Header$ +! +! This subroutine creates the file grilles_gcm.nc containg longitudes and +! latitudes in degrees for grid u and v. This subroutine is called from +! ce0l if grilles_gcm_netcdf=TRUE. This subroutine corresponds to the first +! part in the program create_fausse_var. +! +SUBROUTINE grilles_gcm_netcdf_sub(masque,phis) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comconst.h" + INCLUDE "comgeom.h" + INCLUDE "comvert.h" + INCLUDE "netcdf.inc" + INCLUDE "serre.h" + + + REAL,DIMENSION(iip1,jjp1),INTENT(IN) :: masque ! masque terre/mer + REAL,DIMENSION(iip1,jjp1),INTENT(IN) :: phis ! geopotentiel au sol + + REAL temp(iim+1,jjm+1) + ! Attributs netcdf sortie + INTEGER ncid_out,rcode_out + INTEGER out_lonuid,out_lonvid,out_latuid,out_latvid,out_levid + INTEGER out_varid + INTEGER out_lonudim,out_lonvdim + INTEGER out_latudim,out_latvdim,out_dim(3) + INTEGER out_levdim + + INTEGER, PARAMETER :: longcles = 20 + REAL clesphy0(longcles) + + INTEGER start(4),COUNT(4) + + INTEGER status,i,j + REAL rlatudeg(jjp1),rlatvdeg(jjm),rlevdeg(llm) + REAL rlonudeg(iip1),rlonvdeg(iip1) + + REAL dlon1(iip1),dlon2(iip1),dlat1(jjp1),dlat2(jjp1) + REAL acoslat,dxkm,dykm,resol(iip1,jjp1) + REAL,DIMENSION(iip1,jjp1) :: phis_loc + INTEGER masque_int(iip1,jjp1) + INTEGER :: phis_id + INTEGER :: area_id + INTEGER :: mask_id + + rad = 6400000 + omeg = 7.272205e-05 + g = 9.8 + kappa = 0.285716 + daysec = 86400 + cpp = 1004.70885 + + preff = 101325. + pa= 50000. + + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + CALL iniconst + CALL inigeom + + DO j=1,jjp1 + rlatudeg(j)=rlatu(j)*180./pi + ENDDO + DO j=1,jjm + rlatvdeg(j)=rlatv(j)*180./pi + ENDDO + + DO i=1,iip1 + rlonudeg(i)=rlonu(i)*180./pi + 360. + rlonvdeg(i)=rlonv(i)*180./pi + 360. + ENDDO + + + ! 2 ----- OUVERTURE DE LA SORTIE NETCDF + ! --------------------------------------------------- + ! CREATION OUTPUT + ! ouverture fichier netcdf de sortie out + status=NF_CREATE('grilles_gcm.nc',NF_NOCLOBBER,ncid_out) + status=NF_DEF_DIM(ncid_out,'lonu',iim+1,out_lonudim) + status=NF_DEF_DIM(ncid_out,'lonv',iim+1,out_lonvdim) + status=NF_DEF_DIM(ncid_out,'latu',jjm+1,out_latudim) + status=NF_DEF_DIM(ncid_out,'latv',jjm,out_latvdim) + + + ! Longitudes en u + status=NF_DEF_VAR(ncid_out,'lonu',NF_FLOAT,1,out_lonudim, out_lonuid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'units', 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonuid,'long_name',9,'Longitude en u') + + ! Longitudes en v + status=NF_DEF_VAR(ncid_out,'lonv',NF_FLOAT,1,out_lonvdim, out_lonvid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'units', 12,'degrees_east') + status=NF_PUT_ATT_TEXT(ncid_out,out_lonvid,'long_name', 9,'Longitude en v') + + ! Latitude en u + status=NF_DEF_VAR(ncid_out,'latu',NF_FLOAT,1,out_latudim, out_latuid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'units', 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latuid,'long_name', 8,'Latitude en u') + + ! Latitude en v + status=NF_DEF_VAR(ncid_out,'latv',NF_FLOAT,1,out_latvdim, out_latvid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'units', 13,'degrees_north') + status=NF_PUT_ATT_TEXT(ncid_out,out_latvid,'long_name', 8,'Latitude en v') + + ! ecriture de la grille u + out_dim(1)=out_lonudim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_u',NF_FLOAT,2,out_dim, out_varid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', 16,'Grille aux point u') + + ! ecriture de la grille v + out_dim(1)=out_lonvdim + out_dim(2)=out_latvdim + status=NF_DEF_VAR(ncid_out,'grille_v',NF_FLOAT,2,out_dim, out_varid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name', 16,'Grille aux point v') + + ! ecriture de la grille u + out_dim(1)=out_lonvdim + out_dim(2)=out_latudim + status=NF_DEF_VAR(ncid_out,'grille_s',NF_FLOAT,2,out_dim, out_varid) + CALL handle_err(status) + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'units', 6,'Kelvin') + status=NF_PUT_ATT_TEXT(ncid_out,out_varid,'long_name',16,'Grille aux point u') + + status=NF_ENDDEF(ncid_out) + ! 5) ----- FERMETURE DES FICHIERS NETCDF------------------ + ! -------------------------------------------------------- + ! 3-b- Ecriture de la grille pour la sortie + ! rajoute l'ecriture de la grille + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_DOUBLE(ncid_out,out_latvid,1,jjm,rlatvdeg) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_lonuid,1,iim+1,rlonudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_lonvid,1,iim+1,rlonvdeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latuid,1,jjm+1,rlatudeg) + status=NF_PUT_VARA_REAL(ncid_out,out_latvid,1,jjm,rlatvdeg) +#endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=1 + + COUNT(1)=iim+1 + COUNT(2)=jjm+1 + COUNT(3)=1 + COUNT(4)=1 + + DO j=1,jjm+1 + DO i=1,iim+1 + temp(i,j)=MOD(i,2)+MOD(j,2) + ENDDO + ENDDO + +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_varid,start, count,temp) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_varid,start, count,temp) +#endif + + ! On re-ouvre le fichier pour rajouter 4 nouvelles variables necessaire pour INCA +! lev - phis - aire - mask + rlevdeg(:) = presnivs + phis_loc(:,:) = phis(:,:)/g + +! niveaux de pression verticaux + status = NF_REDEF (ncid_out) + status=NF_DEF_DIM(ncid_out,'lev',llm,out_levdim) + +! fields + out_dim(1)=out_lonvdim + out_dim(2)=out_latudim + + status = nf_def_var(ncid_out,'phis',NF_FLOAT,2,out_dim,phis_id) + CALL handle_err(status) + status = nf_def_var(ncid_out,'aire',NF_FLOAT,2,out_dim,area_id) + CALL handle_err(status) + status = nf_def_var(ncid_out,'mask',NF_INT ,2,out_dim,mask_id) + CALL handle_err(status) + + status=NF_ENDDEF(ncid_out) + + ! ecriture des variables +#ifdef NC_DOUBLE + status=NF_PUT_VARA_DOUBLE(ncid_out,out_levid,1,llm,rlevdeg) +#else + status=NF_PUT_VARA_REAL(ncid_out,out_levid,1,llm,rlevdeg) +#endif + + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=0 + COUNT(1)=iip1 + COUNT(2)=jjp1 + COUNT(3)=1 + COUNT(4)=0 + + status = nf_put_vara_double(ncid_out, phis_id,start,count, phis_loc) + status = nf_put_vara_double(ncid_out, area_id,start,count, aire) + masque_int(:,:) = nINT(masque(:,:)) + status = nf_put_vara_int(ncid_out, mask_id,start,count,masque_int) + CALL handle_err(status) + + ! fermeture du fichier netcdf + CALL ncclos(ncid_out,rcode_out) + +END SUBROUTINE grilles_gcm_netcdf_sub + + + +SUBROUTINE handle_err(status) + INCLUDE "netcdf.inc" + + INTEGER status + IF (status.NE.nf_noerr) THEN + PRINT *,NF_STRERROR(status) + CALL abort_gcm('grilles_gcm_netcdf','netcdf error',1) + ENDIF +END SUBROUTINE handle_err + Index: LMDZ5/trunk/libf/dyn3d_common/iniconst.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/iniconst.F90 (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/iniconst.F90 (revision 1952) @@ -0,0 +1,84 @@ +! +! $Id$ +! +SUBROUTINE iniconst + + USE control_mod +#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 + ! + ! P. Le Van + ! + ! Declarations: + ! ------------- + ! + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "temps.h" + include "comvert.h" + include "iniprint.h" + + character(len=*),parameter :: modname="iniconst" + character(len=80) :: abort_message + ! + ! + ! + !----------------------------------------------------------------------- + ! dimension des boucles: + ! ---------------------- + + im = iim + jm = jjm + lllm = llm + imp1 = iim + jmp1 = jjm + 1 + lllmm1 = llm - 1 + lllmp1 = llm + 1 + + !----------------------------------------------------------------------- + + dtphys = iphysiq * dtvr + unsim = 1./iim + pi = 2.*ASIN( 1. ) + + !----------------------------------------------------------------------- + ! + + r = cpp * kappa + + write(lunout,*) trim(modname),': R CP Kappa ',r,cpp,kappa + ! + !----------------------------------------------------------------------- + + ! vertical discretization: default behavior depends on planet_type flag + if (planet_type=="earth") then + disvert_type=1 + else + disvert_type=2 + endif + ! but user can also specify using one or the other in run.def: + call getin('disvert_type',disvert_type) + write(lunout,*) trim(modname),': disvert_type=',disvert_type + + pressure_exner = disvert_type == 1 ! default value + call getin('pressure_exner', pressure_exner) + + if (disvert_type==1) then + ! standard case for Earth (automatic generation of levels) + call disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig, scaleheight) + else if (disvert_type==2) then + ! standard case for planets (levels generated using z2sig.def file) + call disvert_noterre + else + write(abort_message,*) "Wrong value for disvert_type: ", disvert_type + call abort_gcm(modname,abort_message,0) + endif + +END SUBROUTINE iniconst Index: LMDZ5/trunk/libf/dyn3d_common/inidissip.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/inidissip.F90 (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/inidissip.F90 (revision 1952) @@ -0,0 +1,223 @@ +! +! $Id$ +! +SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh , & + tetagdiv,tetagrot,tetatemp, vert_prof_dissip) + !======================================================================= + ! initialisation de la dissipation horizontale + !======================================================================= + !----------------------------------------------------------------------- + ! declarations: + ! ------------- + + USE control_mod, only : dissip_period,iperiod + + IMPLICIT NONE + include "dimensions.h" + include "paramet.h" + include "comdissipn.h" + include "comconst.h" + include "comvert.h" + include "logic.h" + include "iniprint.h" + + LOGICAL,INTENT(in) :: lstardis + INTEGER,INTENT(in) :: nitergdiv,nitergrot,niterh + REAL,INTENT(in) :: tetagdiv,tetagrot,tetatemp + + integer, INTENT(in):: vert_prof_dissip + ! Vertical profile of horizontal dissipation + ! Allowed values: + ! 0: rational fraction, function of pressure + ! 1: tanh of altitude + +! Local variables: + REAL fact,zvert(llm),zz + REAL zh(ip1jmp1),zu(ip1jmp1), gx(ip1jmp1), divgra(ip1jmp1) + real zv(ip1jm), gy(ip1jm), deltap(ip1jmp1,llm) + REAL ullm,vllm,umin,vmin,zhmin,zhmax + REAL zllm + + INTEGER l,ij,idum,ii + REAL tetamin + REAL pseudoz + character (len=80) :: abort_message + + REAL ran1 + + + !----------------------------------------------------------------------- + ! + ! calcul des valeurs propres des operateurs par methode iterrative: + ! ----------------------------------------------------------------- + + crot = -1. + cdivu = -1. + cdivh = -1. + + ! calcul de la valeur propre de divgrad: + ! -------------------------------------- + idum = 0 + DO l = 1, llm + DO ij = 1, ip1jmp1 + deltap(ij,l) = 1. + ENDDO + ENDDO + + idum = -1 + zh(1) = RAN1(idum)-.5 + idum = 0 + DO ij = 2, ip1jmp1 + zh(ij) = RAN1(idum) -.5 + ENDDO + + CALL filtreg (zh,jjp1,1,2,1,.TRUE.,1) + + CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) + + IF ( zhmin .GE. zhmax ) THEN + write(lunout,*)' Inidissip zh min max ',zhmin,zhmax + abort_message='probleme generateur alleatoire dans inidissip' + call abort_gcm('inidissip',abort_message,1) + ENDIF + + zllm = ABS( zhmax ) + DO l = 1,50 + IF(lstardis) THEN + CALL divgrad2(1,zh,deltap,niterh,divgra) + ELSE + CALL divgrad (1,zh,niterh,divgra) + ENDIF + + zllm = ABS(maxval(divgra)) + zh = divgra / zllm + ENDDO + + IF(lstardis) THEN + cdivh = 1./ zllm + ELSE + cdivh = zllm ** ( -1./niterh ) + ENDIF + + ! calcul des valeurs propres de gradiv (ii =1) et nxgrarot(ii=2) + ! ----------------------------------------------------------------- + write(lunout,*)'inidissip: calcul des valeurs propres' + + DO ii = 1, 2 + ! + DO ij = 1, ip1jmp1 + zu(ij) = RAN1(idum) -.5 + ENDDO + CALL filtreg (zu,jjp1,1,2,1,.TRUE.,1) + DO ij = 1, ip1jm + zv(ij) = RAN1(idum) -.5 + ENDDO + CALL filtreg (zv,jjm,1,2,1,.FALSE.,1) + + CALL minmax(iip1*jjp1,zu,umin,ullm ) + CALL minmax(iip1*jjm, zv,vmin,vllm ) + + ullm = ABS ( ullm ) + vllm = ABS ( vllm ) + + DO l = 1, 50 + IF(ii.EQ.1) THEN + !cccc CALL covcont( 1,zu,zv,zu,zv ) + IF(lstardis) THEN + CALL gradiv2( 1,zu,zv,nitergdiv,gx,gy ) + ELSE + CALL gradiv ( 1,zu,zv,nitergdiv,gx,gy ) + ENDIF + ELSE + IF(lstardis) THEN + CALL nxgraro2( 1,zu,zv,nitergrot,gx,gy ) + ELSE + CALL nxgrarot( 1,zu,zv,nitergrot,gx,gy ) + ENDIF + ENDIF + + zllm = max(abs(maxval(gx)), abs(maxval(gy))) + zu = gx / zllm + zv = gy / zllm + end DO + + IF ( ii.EQ.1 ) THEN + IF(lstardis) THEN + cdivu = 1./zllm + ELSE + cdivu = zllm **( -1./nitergdiv ) + ENDIF + ELSE + IF(lstardis) THEN + crot = 1./ zllm + ELSE + crot = zllm **( -1./nitergrot ) + ENDIF + ENDIF + + end DO + + ! petit test pour les operateurs non star: + ! ---------------------------------------- + + ! IF(.NOT.lstardis) THEN + fact = rad*24./REAL(jjm) + fact = fact*fact + write(lunout,*)'inidissip: coef u ', fact/cdivu, 1./cdivu + write(lunout,*)'inidissip: coef r ', fact/crot , 1./crot + write(lunout,*)'inidissip: coef h ', fact/cdivh, 1./cdivh + ! ENDIF + + !----------------------------------------------------------------------- + ! variation verticale du coefficient de dissipation: + ! -------------------------------------------------- + + if (vert_prof_dissip == 1) then + do l=1,llm + pseudoz=8.*log(preff/presnivs(l)) + zvert(l)=1+ & + (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2. & + *(dissip_factz-1.) + enddo + else + DO l=1,llm + zvert(l)=1. + ENDDO + fact=2. + DO l = 1, llm + zz = 1. - preff/presnivs(l) + zvert(l)= fact -( fact-1.)/( 1.+zz*zz ) + ENDDO + endif + + + write(lunout,*)'inidissip: Constantes de temps de la diffusion horizontale' + + tetamin = 1.e+6 + + DO l=1,llm + tetaudiv(l) = zvert(l)/tetagdiv + tetaurot(l) = zvert(l)/tetagrot + tetah(l) = zvert(l)/tetatemp + + IF( tetamin.GT. (1./tetaudiv(l)) ) tetamin = 1./ tetaudiv(l) + IF( tetamin.GT. (1./tetaurot(l)) ) tetamin = 1./ tetaurot(l) + IF( tetamin.GT. (1./ tetah(l)) ) tetamin = 1./ tetah(l) + ENDDO + + ! If dissip_period=0 calculate value for dissipation period, else keep value read from gcm.def + IF (dissip_period == 0) THEN + dissip_period = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod + write(lunout,*)'inidissip: tetamin dtvr iperiod dissip_period(intermed) ',tetamin,dtvr,iperiod,dissip_period + dissip_period = MAX(iperiod,dissip_period) + END IF + + dtdiss = dissip_period * dtvr + write(lunout,*)'inidissip: dissip_period=',dissip_period,' dtdiss=',dtdiss,' dtvr=',dtvr + + DO l = 1,llm + write(lunout,*)zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l), & + dtdiss*tetah(l) + ENDDO + +END SUBROUTINE inidissip Index: LMDZ5/trunk/libf/dyn3d_common/inigeom.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/inigeom.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/inigeom.F (revision 1952) @@ -0,0 +1,699 @@ +! +! $Id$ +! +c +c + SUBROUTINE inigeom +c +c Auteur : P. Le Van +c +c ............ Version du 01/04/2001 ........................ +c +c Calcul des elongations cuij1,.cuij4 , cvij1,..cvij4 aux memes en- +c endroits que les aires aireij1,..aireij4 . + +c Choix entre f(y) a derivee sinusoid. ou a derivee tangente hyperbol. +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" +#include "serre.h" +#include "logic.h" +#include "comdissnew.h" + +c----------------------------------------------------------------------- +c .... Variables locales .... +c + INTEGER i,j,itmax,itmay,iter + REAL cvu(iip1,jjp1),cuv(iip1,jjm) + REAL ai14,ai23,airez,rlatp,rlatm,xprm,xprp,un4rad2,yprp,yprm + REAL eps,x1,xo1,f,df,xdm,y1,yo1,ydm + REAL coslatm,coslatp,radclatm,radclatp + REAL cuij1(iip1,jjp1),cuij2(iip1,jjp1),cuij3(iip1,jjp1), + * cuij4(iip1,jjp1) + REAL cvij1(iip1,jjp1),cvij2(iip1,jjp1),cvij3(iip1,jjp1), + * cvij4(iip1,jjp1) + REAL rlonvv(iip1),rlatuu(jjp1) + REAL rlatu1(jjm),yprimu1(jjm),rlatu2(jjm),yprimu2(jjm) , + * yprimv(jjm),yprimu(jjp1) + REAL gamdi_gdiv, gamdi_grot, gamdi_h + + REAL rlonm025(iip1),xprimm025(iip1), rlonp025(iip1), + , xprimp025(iip1) + SAVE rlatu1,yprimu1,rlatu2,yprimu2,yprimv,yprimu + SAVE rlonm025,xprimm025,rlonp025,xprimp025 + + REAL SSUM +c +c +c ------------------------------------------------------------------ +c - - +c - calcul des coeff. ( cu, cv , 1./cu**2, 1./cv**2 ) - +c - - +c ------------------------------------------------------------------ +c +c les coef. ( cu, cv ) permettent de passer des vitesses naturelles +c aux vitesses covariantes et contravariantes , ou vice-versa ... +c +c +c on a : u (covariant) = cu * u (naturel) , u(contrav)= u(nat)/cu +c v (covariant) = cv * v (naturel) , v(contrav)= v(nat)/cv +c +c on en tire : u(covariant) = cu * cu * u(contravariant) +c v(covariant) = cv * cv * v(contravariant) +c +c +c on a l'application ( x(X) , y(Y) ) avec - im/2 +1 < X < im/2 +c = = +c et - jm/2 < Y < jm/2 +c = = +c +c ................................................... +c ................................................... +c . x est la longitude du point en radians . +c . y est la latitude du point en radians . +c . . +c . on a : cu(i,j) = rad * COS(y) * dx/dX . +c . cv( j ) = rad * dy/dY . +c . aire(i,j) = cu(i,j) * cv(j) . +c . . +c . y, dx/dX, dy/dY calcules aux points concernes . +c . . +c ................................................... +c ................................................... +c +c +c +c , +c cv , bien que dependant de j uniquement,sera ici indice aussi en i +c pour un adressage plus facile en ij . +c +c +c +c ************** aux points u et v , ***************** +c xprimu et xprimv sont respectivement les valeurs de dx/dX +c yprimu et yprimv . . . . . . . . . . . dy/dY +c rlatu et rlatv . . . . . . . . . . .la latitude +c cvu et cv . . . . . . . . . . . cv +c +c ************** aux points u, v, scalaires, et z **************** +c cu, cuv, cuscal, cuz sont respectiv. les valeurs de cu +c +c +c +c Exemple de distribution de variables sur la grille dans le +c domaine de travail ( X,Y ) . +c ................................................................ +c DX=DY= 1 +c +c +c + represente un point scalaire ( p.exp la pression ) +c > represente la composante zonale du vent +c V represente la composante meridienne du vent +c o represente la vorticite +c +c ---- , car aux poles , les comp.zonales covariantes sont nulles +c +c +c +c i -> +c +c 1 2 3 4 5 6 7 8 +c j +c v 1 + ---- + ---- + ---- + ---- + ---- + ---- + ---- + -- +c +c V o V o V o V o V o V o V o V o +c +c 2 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 3 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 4 + > + > + > + > + > + > + > + > +c +c V o V o V o V o V o V o V o V o +c +c 5 + ---- + ---- + ---- + ---- + ---- + ---- + ---- + -- +c +c +c Ci-dessus, on voit que le nombre de pts.en longitude est egal +c a IM = 8 +c De meme , le nombre d'intervalles entre les 2 poles est egal +c a JM = 4 +c +c Les points scalaires ( + ) correspondent donc a des valeurs +c entieres de i ( 1 a IM ) et de j ( 1 a JM +1 ) . +c +c Les vents U ( > ) correspondent a des valeurs semi- +c entieres de i ( 1+ 0.5 a IM+ 0.5) et entieres de j ( 1 a JM+1) +c +c Les vents V ( V ) correspondent a des valeurs entieres +c de i ( 1 a IM ) et semi-entieres de j ( 1 +0.5 a JM +0.5) +c +c +c + WRITE(6,3) + 3 FORMAT( // 10x,' .... INIGEOM date du 01/06/98 ..... ', + * //5x,' Calcul des elongations cu et cv comme sommes des 4 ' / + * 5x,' elong. cuij1, .. 4 , cvij1,.. 4 qui les entourent , aux + * '/ 5x,' memes endroits que les aires aireij1,...j4 . ' / ) +c +c + IF( nitergdiv.NE.2 ) THEN + gamdi_gdiv = coefdis/ ( REAL(nitergdiv) -2. ) + ELSE + gamdi_gdiv = 0. + ENDIF + IF( nitergrot.NE.2 ) THEN + gamdi_grot = coefdis/ ( REAL(nitergrot) -2. ) + ELSE + gamdi_grot = 0. + ENDIF + IF( niterh.NE.2 ) THEN + gamdi_h = coefdis/ ( REAL(niterh) -2. ) + ELSE + gamdi_h = 0. + ENDIF + + WRITE(6,*) ' gamdi_gd ',gamdi_gdiv,gamdi_grot,gamdi_h,coefdis, + * nitergdiv,nitergrot,niterh +c + pi = 2.* ASIN(1.) +c + WRITE(6,990) + +c ---------------------------------------------------------------- +c + IF( .NOT.fxyhypb ) THEN +c +c + IF( ysinus ) THEN +c + WRITE(6,*) ' *** Inigeom , Y = Sinus ( Latitude ) *** ' +c +c .... utilisation de f(x,y ) avec y = sinus de la latitude ..... + + CALL fxysinus (rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + ELSE +c + WRITE(6,*) '*** Inigeom , Y = Latitude , der. sinusoid . ***' + +c .... utilisation de f(x,y) a tangente sinusoidale , y etant la latit. ... +c + + pxo = clon *pi /180. + pyo = 2.* clat* pi /180. +c +c .... determination de transx ( pour le zoom ) par Newton-Raphson ... +c + itmax = 10 + eps = .1e-7 +c + xo1 = 0. + DO 10 iter = 1, itmax + x1 = xo1 + f = x1+ alphax *SIN(x1-pxo) + df = 1.+ alphax *COS(x1-pxo) + x1 = x1 - f/df + xdm = ABS( x1- xo1 ) + IF( xdm.LE.eps )GO TO 11 + xo1 = x1 + 10 CONTINUE + 11 CONTINUE +c + transx = xo1 + + itmay = 10 + eps = .1e-7 +C + yo1 = 0. + DO 15 iter = 1,itmay + y1 = yo1 + f = y1 + alphay* SIN(y1-pyo) + df = 1. + alphay* COS(y1-pyo) + y1 = y1 -f/df + ydm = ABS(y1-yo1) + IF(ydm.LE.eps) GO TO 17 + yo1 = y1 + 15 CONTINUE +c + 17 CONTINUE + transy = yo1 + + CALL fxy ( rlatu,yprimu,rlatv,yprimv,rlatu1,yprimu1, + , rlatu2,yprimu2, + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + ENDIF +c + ELSE +c +c .... Utilisation de fxyhyper , f(x,y) a derivee tangente hyperbol. +c ..................................................................... + + WRITE(6,*)'*** Inigeom , Y = Latitude , der.tg. hyperbolique ***' + + CALL fxyhyper( clat, grossismy, dzoomy, tauy , + , clon, grossismx, dzoomx, taux , + , rlatu,yprimu,rlatv, yprimv,rlatu1, yprimu1,rlatu2,yprimu2 , + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025 ) + + + ENDIF +c +c ------------------------------------------------------------------- + +c + rlatu(1) = ASIN(1.) + rlatu(jjp1) = - rlatu(1) +c +c +c .... calcul aux poles .... +c + yprimu(1) = 0. + yprimu(jjp1) = 0. +c +c + un4rad2 = 0.25 * rad * rad +c +c -------------------------------------------------------------------- +c -------------------------------------------------------------------- +c - - +c - calcul des aires ( aire,aireu,airev, 1./aire, 1./airez ) - +c - et de fext , force de coriolis extensive . - +c - - +c -------------------------------------------------------------------- +c -------------------------------------------------------------------- +c +c +c +c A 1 point scalaire P (i,j) de la grille, reguliere en (X,Y) , sont +c affectees 4 aires entourant P , calculees respectivement aux points +c ( i + 1/4, j - 1/4 ) : aireij1 (i,j) +c ( i + 1/4, j + 1/4 ) : aireij2 (i,j) +c ( i - 1/4, j + 1/4 ) : aireij3 (i,j) +c ( i - 1/4, j - 1/4 ) : aireij4 (i,j) +c +c , +c Les cotes de chacun de ces 4 carres etant egaux a 1/2 suivant (X,Y). +c Chaque aire centree en 1 point scalaire P(i,j) est egale a la somme +c des 4 aires aireij1,aireij2,aireij3,aireij4 qui sont affectees au +c point (i,j) . +c On definit en outre les coefficients alpha comme etant egaux a +c (aireij / aire), c.a.d par exp. alpha1(i,j)=aireij1(i,j)/aire(i,j) +c +c De meme, toute aire centree en 1 point U est egale a la somme des +c 4 aires aireij1,aireij2,aireij3,aireij4 entourant le point U . +c Idem pour airev, airez . +c +c On a ,pour chaque maille : dX = dY = 1 +c +c +c . V +c +c aireij4 . . aireij1 +c +c U . . P . U +c +c aireij3 . . aireij2 +c +c . V +c +c +c +c +c +c .................................................................... +c +c Calcul des 4 aires elementaires aireij1,aireij2,aireij3,aireij4 +c qui entourent chaque aire(i,j) , ainsi que les 4 elongations elemen +c taires cuij et les 4 elongat. cvij qui sont calculees aux memes +c endroits que les aireij . +c +c .................................................................... +c +c ....... do 35 : boucle sur les jjm + 1 latitudes ..... +c +c + DO 35 j = 1, jjp1 +c + IF ( j. eq. 1 ) THEN +c + yprm = yprimu1(j) + rlatm = rlatu1(j) +c + coslatm = COS( rlatm ) + radclatm = 0.5* rad * coslatm +c + DO 30 i = 1, iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + aireij2( i,1 ) = un4rad2 * coslatm * xprp * yprm + aireij3( i,1 ) = un4rad2 * coslatm * xprm * yprm + cuij2 ( i,1 ) = radclatm * xprp + cuij3 ( i,1 ) = radclatm * xprm + cvij2 ( i,1 ) = 0.5* rad * yprm + cvij3 ( i,1 ) = cvij2(i,1) + 30 CONTINUE +c + DO i = 1, iim + aireij1( i,1 ) = 0. + aireij4( i,1 ) = 0. + cuij1 ( i,1 ) = 0. + cuij4 ( i,1 ) = 0. + cvij1 ( i,1 ) = 0. + cvij4 ( i,1 ) = 0. + ENDDO +c + END IF +c + IF ( j. eq. jjp1 ) THEN + yprp = yprimu2(j-1) + rlatp = rlatu2 (j-1) +ccc yprp = fyprim( REAL(j) - 0.25 ) +ccc rlatp = fy ( REAL(j) - 0.25 ) +c + coslatp = COS( rlatp ) + radclatp = 0.5* rad * coslatp +c + DO 31 i = 1,iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + aireij1( i,jjp1 ) = un4rad2 * coslatp * xprp * yprp + aireij4( i,jjp1 ) = un4rad2 * coslatp * xprm * yprp + cuij1(i,jjp1) = radclatp * xprp + cuij4(i,jjp1) = radclatp * xprm + cvij1(i,jjp1) = 0.5 * rad* yprp + cvij4(i,jjp1) = cvij1(i,jjp1) + 31 CONTINUE +c + DO i = 1, iim + aireij2( i,jjp1 ) = 0. + aireij3( i,jjp1 ) = 0. + cvij2 ( i,jjp1 ) = 0. + cvij3 ( i,jjp1 ) = 0. + cuij2 ( i,jjp1 ) = 0. + cuij3 ( i,jjp1 ) = 0. + ENDDO +c + END IF +c + + IF ( j .gt. 1 .AND. j .lt. jjp1 ) THEN +c + rlatp = rlatu2 ( j-1 ) + yprp = yprimu2( j-1 ) + rlatm = rlatu1 ( j ) + yprm = yprimu1( j ) +cc rlatp = fy ( REAL(j) - 0.25 ) +cc yprp = fyprim( REAL(j) - 0.25 ) +cc rlatm = fy ( REAL(j) + 0.25 ) +cc yprm = fyprim( REAL(j) + 0.25 ) + + coslatm = COS( rlatm ) + coslatp = COS( rlatp ) + radclatp = 0.5* rad * coslatp + radclatm = 0.5* rad * coslatm +c + ai14 = un4rad2 * coslatp * yprp + ai23 = un4rad2 * coslatm * yprm + DO 32 i = 1,iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + + aireij1 ( i,j ) = ai14 * xprp + aireij2 ( i,j ) = ai23 * xprp + aireij3 ( i,j ) = ai23 * xprm + aireij4 ( i,j ) = ai14 * xprm + cuij1 ( i,j ) = radclatp * xprp + cuij2 ( i,j ) = radclatm * xprp + cuij3 ( i,j ) = radclatm * xprm + cuij4 ( i,j ) = radclatp * xprm + cvij1 ( i,j ) = 0.5* rad * yprp + cvij2 ( i,j ) = 0.5* rad * yprm + cvij3 ( i,j ) = cvij2(i,j) + cvij4 ( i,j ) = cvij1(i,j) + 32 CONTINUE +c + END IF +c +c ........ periodicite ............ +c + cvij1 (iip1,j) = cvij1 (1,j) + cvij2 (iip1,j) = cvij2 (1,j) + cvij3 (iip1,j) = cvij3 (1,j) + cvij4 (iip1,j) = cvij4 (1,j) + cuij1 (iip1,j) = cuij1 (1,j) + cuij2 (iip1,j) = cuij2 (1,j) + cuij3 (iip1,j) = cuij3 (1,j) + cuij4 (iip1,j) = cuij4 (1,j) + aireij1 (iip1,j) = aireij1 (1,j ) + aireij2 (iip1,j) = aireij2 (1,j ) + aireij3 (iip1,j) = aireij3 (1,j ) + aireij4 (iip1,j) = aireij4 (1,j ) + + 35 CONTINUE +c +c .............................................................. +c + DO 37 j = 1, jjp1 + DO 36 i = 1, iim + aire ( i,j ) = aireij1(i,j) + aireij2(i,j) + aireij3(i,j) + + * aireij4(i,j) + alpha1 ( i,j ) = aireij1(i,j) / aire(i,j) + alpha2 ( i,j ) = aireij2(i,j) / aire(i,j) + alpha3 ( i,j ) = aireij3(i,j) / aire(i,j) + alpha4 ( i,j ) = aireij4(i,j) / aire(i,j) + alpha1p2( i,j ) = alpha1 (i,j) + alpha2 (i,j) + alpha1p4( i,j ) = alpha1 (i,j) + alpha4 (i,j) + alpha2p3( i,j ) = alpha2 (i,j) + alpha3 (i,j) + alpha3p4( i,j ) = alpha3 (i,j) + alpha4 (i,j) + 36 CONTINUE +c +c + aire (iip1,j) = aire (1,j) + alpha1 (iip1,j) = alpha1 (1,j) + alpha2 (iip1,j) = alpha2 (1,j) + alpha3 (iip1,j) = alpha3 (1,j) + alpha4 (iip1,j) = alpha4 (1,j) + alpha1p2(iip1,j) = alpha1p2(1,j) + alpha1p4(iip1,j) = alpha1p4(1,j) + alpha2p3(iip1,j) = alpha2p3(1,j) + alpha3p4(iip1,j) = alpha3p4(1,j) + 37 CONTINUE +c + + DO 42 j = 1,jjp1 + DO 41 i = 1,iim + aireu (i,j)= aireij1(i,j) + aireij2(i,j) + aireij4(i+1,j) + + * aireij3(i+1,j) + unsaire ( i,j)= 1./ aire(i,j) + unsair_gam1( i,j)= unsaire(i,j)** ( - gamdi_gdiv ) + unsair_gam2( i,j)= unsaire(i,j)** ( - gamdi_h ) + airesurg ( i,j)= aire(i,j)/ g + 41 CONTINUE + aireu (iip1,j) = aireu (1,j) + unsaire (iip1,j) = unsaire(1,j) + unsair_gam1(iip1,j) = unsair_gam1(1,j) + unsair_gam2(iip1,j) = unsair_gam2(1,j) + airesurg (iip1,j) = airesurg(1,j) + 42 CONTINUE +c +c + DO 48 j = 1,jjm +c + DO i=1,iim + airev (i,j) = aireij2(i,j)+ aireij3(i,j)+ aireij1(i,j+1) + + * aireij4(i,j+1) + ENDDO + DO i=1,iim + airez = aireij2(i,j)+aireij1(i,j+1)+aireij3(i+1,j) + + * aireij4(i+1,j+1) + unsairez(i,j) = 1./ airez + unsairz_gam(i,j)= unsairez(i,j)** ( - gamdi_grot ) + fext (i,j) = airez * SIN(rlatv(j))* 2.* omeg + ENDDO + airev (iip1,j) = airev(1,j) + unsairez (iip1,j) = unsairez(1,j) + fext (iip1,j) = fext(1,j) + unsairz_gam(iip1,j) = unsairz_gam(1,j) +c + 48 CONTINUE +c +c +c ..... Calcul des elongations cu,cv, cvu ......... +c + DO j = 1, jjm + DO i = 1, iim + cv(i,j) = 0.5 *( cvij2(i,j)+cvij3(i,j)+cvij1(i,j+1)+cvij4(i,j+1)) + cvu(i,j)= 0.5 *( cvij1(i,j)+cvij4(i,j)+cvij2(i,j) +cvij3(i,j) ) + cuv(i,j)= 0.5 *( cuij2(i,j)+cuij3(i,j)+cuij1(i,j+1)+cuij4(i,j+1)) + unscv2(i,j) = 1./ ( cv(i,j)*cv(i,j) ) + ENDDO + DO i = 1, iim + cuvsurcv (i,j) = airev(i,j) * unscv2(i,j) + cvsurcuv (i,j) = 1./cuvsurcv(i,j) + cuvscvgam1(i,j) = cuvsurcv (i,j) ** ( - gamdi_gdiv ) + cuvscvgam2(i,j) = cuvsurcv (i,j) ** ( - gamdi_h ) + cvscuvgam(i,j) = cvsurcuv (i,j) ** ( - gamdi_grot ) + ENDDO + cv (iip1,j) = cv (1,j) + cvu (iip1,j) = cvu (1,j) + unscv2 (iip1,j) = unscv2 (1,j) + cuv (iip1,j) = cuv (1,j) + cuvsurcv (iip1,j) = cuvsurcv (1,j) + cvsurcuv (iip1,j) = cvsurcuv (1,j) + cuvscvgam1(iip1,j) = cuvscvgam1(1,j) + cuvscvgam2(iip1,j) = cuvscvgam2(1,j) + cvscuvgam(iip1,j) = cvscuvgam(1,j) + ENDDO + + DO j = 2, jjm + DO i = 1, iim + cu(i,j) = 0.5*(cuij1(i,j)+cuij4(i+1,j)+cuij2(i,j)+cuij3(i+1,j)) + unscu2 (i,j) = 1./ ( cu(i,j) * cu(i,j) ) + cvusurcu (i,j) = aireu(i,j) * unscu2(i,j) + cusurcvu (i,j) = 1./ cvusurcu(i,j) + cvuscugam1 (i,j) = cvusurcu(i,j) ** ( - gamdi_gdiv ) + cvuscugam2 (i,j) = cvusurcu(i,j) ** ( - gamdi_h ) + cuscvugam (i,j) = cusurcvu(i,j) ** ( - gamdi_grot ) + ENDDO + cu (iip1,j) = cu(1,j) + unscu2 (iip1,j) = unscu2(1,j) + cvusurcu (iip1,j) = cvusurcu(1,j) + cusurcvu (iip1,j) = cusurcvu(1,j) + cvuscugam1(iip1,j) = cvuscugam1(1,j) + cvuscugam2(iip1,j) = cvuscugam2(1,j) + cuscvugam (iip1,j) = cuscvugam(1,j) + ENDDO + +c +c .... calcul aux poles .... +c + DO i = 1, iip1 + cu ( i, 1 ) = 0. + unscu2( i, 1 ) = 0. + cvu ( i, 1 ) = 0. +c + cu (i, jjp1) = 0. + unscu2(i, jjp1) = 0. + cvu (i, jjp1) = 0. + ENDDO +c +c .............................................................. +c + DO j = 1, jjm + DO i= 1, iim + airvscu2 (i,j) = airev(i,j)/ ( cuv(i,j) * cuv(i,j) ) + aivscu2gam(i,j) = airvscu2(i,j)** ( - gamdi_grot ) + ENDDO + airvscu2 (iip1,j) = airvscu2(1,j) + aivscu2gam(iip1,j) = aivscu2gam(1,j) + ENDDO + + DO j=2,jjm + DO i=1,iim + airuscv2 (i,j) = aireu(i,j)/ ( cvu(i,j) * cvu(i,j) ) + aiuscv2gam (i,j) = airuscv2(i,j)** ( - gamdi_grot ) + ENDDO + airuscv2 (iip1,j) = airuscv2 (1,j) + aiuscv2gam(iip1,j) = aiuscv2gam(1,j) + ENDDO + +c +c calcul des aires aux poles : +c ----------------------------- +c + apoln = SSUM(iim,aire(1,1),1) + apols = SSUM(iim,aire(1,jjp1),1) + unsapolnga1 = 1./ ( apoln ** ( - gamdi_gdiv ) ) + unsapolsga1 = 1./ ( apols ** ( - gamdi_gdiv ) ) + unsapolnga2 = 1./ ( apoln ** ( - gamdi_h ) ) + unsapolsga2 = 1./ ( apols ** ( - gamdi_h ) ) +c +c----------------------------------------------------------------------- +c gtitre='Coriolis version ancienne' +c gfichier='fext1' +c CALL writestd(fext,iip1*jjm) +c +c changement F. Hourdin calcul conservatif pour fext +c constang contient le produit a * cos ( latitude ) * omega +c + DO i=1,iim + constang(i,1) = 0. + ENDDO + DO j=1,jjm-1 + DO i=1,iim + constang(i,j+1) = rad*omeg*cu(i,j+1)*COS(rlatu(j+1)) + ENDDO + ENDDO + DO i=1,iim + constang(i,jjp1) = 0. + ENDDO +c +c periodicite en longitude +c + DO j=1,jjm + fext(iip1,j) = fext(1,j) + ENDDO + DO j=1,jjp1 + constang(iip1,j) = constang(1,j) + ENDDO + +c fin du changement + +c +c----------------------------------------------------------------------- +c + WRITE(6,*) ' *** Coordonnees de la grille *** ' + WRITE(6,995) +c + WRITE(6,*) ' LONGITUDES aux pts. V ( degres ) ' + WRITE(6,995) + DO i=1,iip1 + rlonvv(i) = rlonv(i)*180./pi + ENDDO + WRITE(6,400) rlonvv +c + WRITE(6,995) + WRITE(6,*) ' LATITUDES aux pts. V ( degres ) ' + WRITE(6,995) + DO i=1,jjm + rlatuu(i)=rlatv(i)*180./pi + ENDDO + WRITE(6,400) (rlatuu(i),i=1,jjm) +c + DO i=1,iip1 + rlonvv(i)=rlonu(i)*180./pi + ENDDO + WRITE(6,995) + WRITE(6,*) ' LONGITUDES aux pts. U ( degres ) ' + WRITE(6,995) + WRITE(6,400) rlonvv + WRITE(6,995) + + WRITE(6,*) ' LATITUDES aux pts. U ( degres ) ' + WRITE(6,995) + DO i=1,jjp1 + rlatuu(i)=rlatu(i)*180./pi + ENDDO + WRITE(6,400) (rlatuu(i),i=1,jjp1) + WRITE(6,995) +c +444 format(f10.3,f6.0) +400 FORMAT(1x,8f8.2) +990 FORMAT(//) +995 FORMAT(/) +c + RETURN + END Index: LMDZ5/trunk/libf/dyn3d_common/inter_barxy_m.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/inter_barxy_m.F90 (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/inter_barxy_m.F90 (revision 1952) @@ -0,0 +1,453 @@ +! +! $Id$ +! +module inter_barxy_m + + ! Authors: Robert SADOURNY, Phu LE VAN, Lionel GUEZ + + implicit none + + private + public inter_barxy + +contains + + SUBROUTINE inter_barxy(dlonid, dlatid, champ, rlonimod, rlatimod, champint) + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + + include "dimensions.h" + ! (for "iim", "jjm") + + include "paramet.h" + ! (for other included files) + + include "comgeom2.h" + ! (for "aire", "apoln", "apols") + + REAL, intent(in):: dlonid(:) + ! (longitude from input file, in rad, from -pi to pi) + + REAL, intent(in):: dlatid(:), champ(:, :), rlonimod(:) + + REAL, intent(in):: rlatimod(:) + ! (latitude angle, in degrees or rad, in strictly decreasing order) + + real, intent(out):: champint(:, :) + ! Si taille de la seconde dim = jjm + 1, on veut interpoler sur les + ! jjm+1 latitudes rlatu du modele (latitudes des scalaires et de U) + ! Si taille de la seconde dim = jjm, on veut interpoler sur les + ! jjm latitudes rlatv du modele (latitudes de V) + + ! Variables local to the procedure: + + REAL champy(iim, size(champ, 2)) + integer j, i, jnterfd, jmods + + REAL yjmod(size(champint, 2)) + ! (angle, in degrees, in strictly increasing order) + + REAL yjdat(size(dlatid) + 1) ! angle, in degrees, in increasing order + LOGICAL decrois ! "dlatid" is in decreasing order + + !----------------------------------- + + jnterfd = assert_eq(size(champ, 2) - 1, size(dlatid), & + "inter_barxy jnterfd") + jmods = size(champint, 2) + call assert(size(champ, 1) == size(dlonid), "inter_barxy size(champ, 1)") + call assert((/size(rlonimod), size(champint, 1)/) == iim, & + "inter_barxy iim") + call assert(any(jmods == (/jjm, jjm + 1/)), 'inter_barxy jmods') + call assert(size(rlatimod) == jjm, "inter_barxy size(rlatimod)") + + ! Check decreasing order for "rlatimod": + DO i = 2, jjm + IF (rlatimod(i) >= rlatimod(i-1)) stop & + '"inter_barxy": "rlatimod" should be strictly decreasing' + ENDDO + + yjmod(:jjm) = ord_coordm(rlatimod) + IF (jmods == jjm + 1) THEN + IF (90. - yjmod(jjm) < 0.01) stop & + '"inter_barxy": with jmods = jjm + 1, yjmod(jjm) should be < 90.' + ELSE + ! jmods = jjm + IF (ABS(yjmod(jjm) - 90.) > 0.01) stop & + '"inter_barxy": with jmods = jjm, yjmod(jjm) should be 90.' + ENDIF + + if (jmods == jjm + 1) yjmod(jjm + 1) = 90. + + DO j = 1, jnterfd + 1 + champy(:, j) = inter_barx(dlonid, champ(:, j), rlonimod) + ENDDO + + CALL ord_coord(dlatid, yjdat, decrois) + IF (decrois) champy(:, :) = champy(:, jnterfd + 1:1:-1) + DO i = 1, iim + champint(i, :) = inter_bary(yjdat, champy(i, :), yjmod) + ENDDO + champint(:, :) = champint(:, jmods:1:-1) + + IF (jmods == jjm + 1) THEN + ! Valeurs uniques aux poles + champint(:, 1) = SUM(aire(:iim, 1) * champint(:, 1)) / apoln + champint(:, jjm + 1) = SUM(aire(:iim, jjm + 1) & + * champint(:, jjm + 1)) / apols + ENDIF + + END SUBROUTINE inter_barxy + + !****************************** + + function inter_barx(dlonid, fdat, rlonimod) + + ! INTERPOLATION BARYCENTRIQUE BASEE SUR LES AIRES + ! VERSION UNIDIMENSIONNELLE , EN LONGITUDE . + + ! idat : indice du champ de donnees, de 1 a idatmax + ! imod : indice du champ du modele, de 1 a imodmax + ! fdat(idat) : champ de donnees (entrees) + ! inter_barx(imod) : champ du modele (sorties) + ! dlonid(idat): abscisses des interfaces des mailles donnees + ! rlonimod(imod): abscisses des interfaces des mailles modele + ! ( L'indice 1 correspond a l'interface mailLE 1 / maille 2) + ! ( Les abscisses sont exprimees en degres) + + use assert_eq_m, only: assert_eq + + IMPLICIT NONE + + REAL, intent(in):: dlonid(:) + real, intent(in):: fdat(:) + real, intent(in):: rlonimod(:) + + real inter_barx(size(rlonimod)) + + ! ... Variables locales ... + + INTEGER idatmax, imodmax + REAL xxid(size(dlonid)+1), xxd(size(dlonid)+1), fdd(size(dlonid)+1) + REAL fxd(size(dlonid)+1), xchan(size(dlonid)+1), fdchan(size(dlonid)+1) + REAL xxim(size(rlonimod)) + + REAL x0, xim0, dx, dxm + REAL chmin, chmax, pi + + INTEGER imod, idat, i, ichang, id0, id1, nid, idatmax1 + + !----------------------------------------------------- + + idatmax = assert_eq(size(dlonid), size(fdat), "inter_barx idatmax") + imodmax = size(rlonimod) + + pi = 2. * ASIN(1.) + + ! REDEFINITION DE L'ORIGINE DES ABSCISSES + ! A L'INTERFACE OUEST DE LA PREMIERE MAILLE DU MODELE + DO imod = 1, imodmax + xxim(imod) = rlonimod(imod) + ENDDO + + CALL minmax( imodmax, xxim, chmin, chmax) + IF( chmax.LT.6.50 ) THEN + DO imod = 1, imodmax + xxim(imod) = xxim(imod) * 180./pi + ENDDO + ENDIF + + xim0 = xxim(imodmax) - 360. + + DO imod = 1, imodmax + xxim(imod) = xxim(imod) - xim0 + ENDDO + + idatmax1 = idatmax +1 + + DO idat = 1, idatmax + xxd(idat) = dlonid(idat) + ENDDO + + CALL minmax( idatmax, xxd, chmin, chmax) + IF( chmax.LT.6.50 ) THEN + DO idat = 1, idatmax + xxd(idat) = xxd(idat) * 180./pi + ENDDO + ENDIF + + DO idat = 1, idatmax + xxd(idat) = MOD( xxd(idat) - xim0, 360. ) + fdd(idat) = fdat (idat) + ENDDO + + i = 2 + DO while (xxd(i) >= xxd(i-1) .and. i < idatmax) + i = i + 1 + ENDDO + IF (xxd(i) < xxd(i-1)) THEN + ichang = i + ! *** reorganisation des longitudes entre 0. et 360. degres **** + nid = idatmax - ichang +1 + DO i = 1, nid + xchan (i) = xxd(i+ichang -1 ) + fdchan(i) = fdd(i+ichang -1 ) + ENDDO + DO i=1, ichang -1 + xchan (i+ nid) = xxd(i) + fdchan(i+nid) = fdd(i) + ENDDO + DO i =1, idatmax + xxd(i) = xchan(i) + fdd(i) = fdchan(i) + ENDDO + end IF + + ! translation des champs de donnees par rapport + ! a la nouvelle origine, avec redondance de la + ! maille a cheval sur les bords + + id0 = 0 + id1 = 0 + + DO idat = 1, idatmax + IF ( xxd( idatmax1- idat ).LT.360.) exit + id1 = id1 + 1 + ENDDO + + DO idat = 1, idatmax + IF (xxd(idat).GT.0.) exit + id0 = id0 + 1 + END DO + + IF( id1 /= 0 ) then + DO idat = 1, id1 + xxid(idat) = xxd(idatmax - id1 + idat) - 360. + fxd (idat) = fdd(idatmax - id1 + idat) + END DO + DO idat = 1, idatmax - id1 + xxid(idat + id1) = xxd(idat) + fxd (idat + id1) = fdd(idat) + END DO + end IF + + IF(id0 /= 0) then + DO idat = 1, idatmax - id0 + xxid(idat) = xxd(idat + id0) + fxd (idat) = fdd(idat + id0) + END DO + + DO idat = 1, id0 + xxid (idatmax - id0 + idat) = xxd(idat) + 360. + fxd (idatmax - id0 + idat) = fdd(idat) + END DO + else + DO idat = 1, idatmax + xxid(idat) = xxd(idat) + fxd (idat) = fdd(idat) + ENDDO + end IF + xxid(idatmax1) = xxid(1) + 360. + fxd (idatmax1) = fxd(1) + + ! initialisation du champ du modele + + inter_barx(:) = 0. + + ! iteration + + x0 = xim0 + dxm = 0. + imod = 1 + idat = 1 + + do while (imod <= imodmax) + do while (xxim(imod).GT.xxid(idat)) + dx = xxid(idat) - x0 + dxm = dxm + dx + inter_barx(imod) = inter_barx(imod) + dx * fxd(idat) + x0 = xxid(idat) + idat = idat + 1 + end do + IF (xxim(imod).LT.xxid(idat)) THEN + dx = xxim(imod) - x0 + dxm = dxm + dx + inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm + x0 = xxim(imod) + dxm = 0. + imod = imod + 1 + ELSE + dx = xxim(imod) - x0 + dxm = dxm + dx + inter_barx(imod) = (inter_barx(imod) + dx * fxd(idat)) / dxm + x0 = xxim(imod) + dxm = 0. + imod = imod + 1 + idat = idat + 1 + END IF + end do + + END function inter_barx + + !****************************** + + function inter_bary(yjdat, fdat, yjmod) + + ! Interpolation barycentrique basée sur les aires. + ! Version unidimensionnelle, en latitude. + ! L'indice 1 correspond à l'interface maille 1 -- maille 2. + + use assert_m, only: assert + + IMPLICIT NONE + + REAL, intent(in):: yjdat(:) + ! (angles, ordonnées des interfaces des mailles des données, in + ! degrees, in increasing order) + + REAL, intent(in):: fdat(:) ! champ de données + + REAL, intent(in):: yjmod(:) + ! (ordonnées des interfaces des mailles du modèle) + ! (in degrees, in strictly increasing order) + + REAL inter_bary(size(yjmod)) ! champ du modèle + + ! Variables local to the procedure: + + REAL y0, dy, dym + INTEGER jdat ! indice du champ de données + integer jmod ! indice du champ du modèle + + !------------------------------------ + + call assert(size(yjdat) == size(fdat), "inter_bary") + + ! Initialisation des variables + inter_bary(:) = 0. + y0 = -90. + dym = 0. + jmod = 1 + jdat = 1 + + do while (jmod <= size(yjmod)) + do while (yjmod(jmod) > yjdat(jdat)) + dy = yjdat(jdat) - y0 + dym = dym + dy + inter_bary(jmod) = inter_bary(jmod) + dy * fdat(jdat) + y0 = yjdat(jdat) + jdat = jdat + 1 + end do + IF (yjmod(jmod) < yjdat(jdat)) THEN + dy = yjmod(jmod) - y0 + dym = dym + dy + inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym + y0 = yjmod(jmod) + dym = 0. + jmod = jmod + 1 + ELSE + ! {yjmod(jmod) == yjdat(jdat)} + dy = yjmod(jmod) - y0 + dym = dym + dy + inter_bary(jmod) = (inter_bary(jmod) + dy * fdat(jdat)) / dym + y0 = yjmod(jmod) + dym = 0. + jmod = jmod + 1 + jdat = jdat + 1 + END IF + end do + ! Le test de fin suppose que l'interface 0 est commune aux deux + ! grilles "yjdat" et "yjmod". + + END function inter_bary + + !****************************** + + SUBROUTINE ord_coord(xi, xo, decrois) + + ! This procedure receives an array of latitudes. + ! It converts them to degrees if they are in radians. + ! If the input latitudes are in decreasing order, the procedure + ! reverses their order. + ! Finally, the procedure adds 90° as the last value of the array. + + use assert_eq_m, only: assert_eq + + IMPLICIT NONE + + include "comconst.h" + ! (for "pi") + + REAL, intent(in):: xi(:) + ! (latitude, in degrees or radians, in increasing or decreasing order) + ! ("xi" should contain latitudes from pole to pole. + ! "xi" should contain the latitudes of the boundaries of grid + ! cells, not the centers of grid cells. + ! So the extreme values should not be 90° and -90°.) + + REAL, intent(out):: xo(:) ! angles in degrees + LOGICAL, intent(out):: decrois + + ! Variables local to the procedure: + INTEGER nmax, i + + !-------------------- + + nmax = assert_eq(size(xi), size(xo) - 1, "ord_coord") + + ! Check monotonicity: + decrois = xi(2) < xi(1) + DO i = 3, nmax + IF (decrois .neqv. xi(i) < xi(i-1)) stop & + '"ord_coord": latitudes are not monotonic' + ENDDO + + IF (abs(xi(1)) < pi) then + ! "xi" contains latitudes in radians + xo(:nmax) = xi(:) * 180. / pi + else + ! "xi" contains latitudes in degrees + xo(:nmax) = xi(:) + end IF + + IF (ABS(abs(xo(1)) - 90) < 0.001 .or. ABS(abs(xo(nmax)) - 90) < 0.001) THEN + print *, "ord_coord" + PRINT *, '"xi" should contain the latitudes of the boundaries of ' & + // 'grid cells, not the centers of grid cells.' + STOP + ENDIF + + IF (decrois) xo(:nmax) = xo(nmax:1:- 1) + xo(nmax + 1) = 90. + + END SUBROUTINE ord_coord + + !*********************************** + + function ord_coordm(xi) + + ! This procedure converts to degrees, if necessary, and inverts the + ! order. + + IMPLICIT NONE + + include "comconst.h" + ! (for "pi") + + REAL, intent(in):: xi(:) ! angle, in rad or degrees + REAL ord_coordm(size(xi)) ! angle, in degrees + + !----------------------------- + + IF (xi(1) < 6.5) THEN + ! "xi" is in rad + ord_coordm(:) = xi(size(xi):1:-1) * 180. / pi + else + ! "xi" is in degrees + ord_coordm(:) = xi(size(xi):1:-1) + ENDIF + + END function ord_coordm + +end module inter_barxy_m Index: LMDZ5/trunk/libf/dyn3d_common/interpre.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/interpre.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/interpre.F (revision 1952) @@ -0,0 +1,133 @@ +! +! $Id$ +! + subroutine interpre(q,qppm,w,fluxwppm,masse, + s apppm,bpppm,massebx,masseby,pbaru,pbarv, + s unatppm,vnatppm,psppm) + + USE control_mod + + implicit none + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" + +c--------------------------------------------------- +c Arguments + real apppm(llm+1),bpppm(llm+1) + real q(iip1,jjp1,llm),qppm(iim,jjp1,llm) +c--------------------------------------------------- + real masse(iip1,jjp1,llm) + real massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) + real w(iip1,jjp1,llm+1) + real fluxwppm(iim,jjp1,llm) + real pbaru(iip1,jjp1,llm ) + real pbarv(iip1,jjm,llm) + real unatppm(iim,jjp1,llm) + real vnatppm(iim,jjp1,llm) + real psppm(iim,jjp1) +c--------------------------------------------------- +c Local + real vnat(iip1,jjp1,llm) + real unat(iip1,jjp1,llm) + real fluxw(iip1,jjp1,llm) + real smass(iip1,jjp1) +c---------------------------------------------------- + integer l,ij,i,j + +c CALCUL DE LA PRESSION DE SURFACE +c Les coefficients ap et bp sont passés en common +c Calcul de la pression au sol en mb optimisée pour +c la vectorialisation + + do j=1,jjp1 + do i=1,iip1 + smass(i,j)=0. + enddo + enddo + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + smass(i,j)=smass(i,j)+masse(i,j,l) + enddo + enddo + enddo + + do j=1,jjp1 + do i=1,iim + psppm(i,j)=smass(i,j)/aire(i,j)*g*0.01 + end do + end do + +c RECONSTRUCTION DES CHAMPS CONTRAVARIANTS +c Le programme ppm3d travaille avec les composantes +c de vitesse et pas les flux, on doit donc passer de l'un à l'autre +c Dans le même temps, on fait le changement d'orientation du vent en v + do l=1,llm + do j=1,jjm + do i=1,iip1 + vnat(i,j,l)=-pbarv(i,j,l)/masseby(i,j,l)*cv(i,j) + enddo + enddo + do i=1,iim + vnat(i,jjp1,l)=0. + enddo + do j=1,jjp1 + do i=1,iip1 + unat(i,j,l)=pbaru(i,j,l)/massebx(i,j,l)*cu(i,j) + enddo + enddo + enddo + +c CALCUL DU FLUX MASSIQUE VERTICAL +c Flux en l=1 (sol) nul + fluxw=0. + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + fluxw(i,j,l)=w(i,j,l)*g*0.01/aire(i,j) +C print*,i,j,l,'fluxw(i,j,l)=',fluxw(i,j,l), +C c 'w(i,j,l)=',w(i,j,l) + enddo + enddo + enddo + +c 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 du LMDZ à ceux de Lin + + do l=1,llm+1 + apppm(l)=ap(llm+2-l) + bpppm(l)=bp(llm+2-l) + enddo + + do l=1,llm + do j=1,jjp1 + do i=1,iim + unatppm(i,j,l)=unat(i,j,llm-l+1) + vnatppm(i,j,l)=vnat(i,j,llm-l+1) + fluxwppm(i,j,l)=fluxw(i,j,llm-l+1) + qppm(i,j,l)=q(i,j,llm-l+1) + enddo + enddo + enddo + + return + end + + + + + + Index: LMDZ5/trunk/libf/dyn3d_common/limx.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/limx.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/limx.F (revision 1952) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE limx(s0,sx,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm) + real sx(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + integer n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL q(ip1jmp1,llm) + real dxq(ip1jmp1,llm) + + + REAL new_m,zm + real dxqu(ip1jmp1) + real adxqu(ip1jmp1),dxqmax(ip1jmp1) + + Logical extremum,first + save first + + REAL SSUM,CVMGP,CVMGT + integer ismax,ismin + EXTERNAL SSUM, ismin,ismax + + data first/.true./ + + + DO l = 1,llm + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dxq(ij,l) = sx(ij,l) /sm(ij,l) + ENDDO + ENDDO + +c calcul de la pente a droite et a gauche de la maille + + do l = 1, llm + do ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + enddo + + do ij=iip2,ip1jm + adxqu(ij)=abs(dxqu(ij)) + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do ij=iip2+1,ip1jm + dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij)) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + dxqmax(ij-iim)=dxqmax(ij) + enddo + +c calcul de la pente avec limitation + + do ij=iip2+1,ip1jm + if( dxqu(ij-1)*dxqu(ij).gt.0. + & .and. dxq(ij,l)*dxqu(ij).gt.0.) then + dxq(ij,l)= + & sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l)) + else +c extremum local + dxq(ij,l)=0. + endif + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxq(ij-iim,l)=dxq(ij,l) + enddo + + DO ij=1,ip1jmp1 + sx(ij,l) = dxq(ij,l)*sm(ij,l) + ENDDO + + ENDDO + + RETURN + END Index: LMDZ5/trunk/libf/dyn3d_common/limy.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/limy.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/limy.F (revision 1952) @@ -0,0 +1,194 @@ +c +c $Id$ +c + SUBROUTINE limy(s0,sy,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + real s0(ip1jmp1,llm),sy(ip1jmp1,llm),sm(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL q(ip1jmp1,llm) + REAL airej2,airejjm,airescb(iim),airesch(iim) + real sigv,dyq(ip1jmp1),dyqv(ip1jm) + real adyqv(ip1jm),dyqmax(ip1jmp1) + REAL qbyv(ip1jm,llm) + + REAL qpns,qpsn,appn,apps,dyn1,dys1,dyn2,dys2 + Logical extremum,first + save first + + real convpn,convps,convmpn,convmps + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + save sinlon,coslon,sinlondlon,coslondlon +c +c + REAL SSUM + integer ismax,ismin + EXTERNAL SSUM, convflu,ismin,ismax + EXTERNAL filtreg + + data first/.true./ + + if(first) then + print*,'SCHEMA AMONT NOUVEAU' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + endif + +c + + do l = 1, llm +c + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dyq(ij) = sy(ij,l) / sm ( ij,l ) + ENDDO +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + qpsn = SSUM( iim, airesch ,1 ) / airejjm + +c calcul des pentes aux points v + + do ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + + do ij=iip2,ip1jm + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + enddo + +c calcul des pentes aux poles + +c calcul des pentes limites aux poles + +c print*,dyqv(iip1+1) +c appn=abs(dyq(1)/dyqv(iip1+1)) +c print*,dyq(ip1jm+1) +c print*,dyqv(ip1jm-iip1+1) +c apps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +c do ij=2,iim +c appn=amax1(abs(dyq(ij)/dyqv(ij)),appn) +c apps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),apps) +c enddo +c appn=min(pente_max/appn,1.) +c apps=min(pente_max/apps,1.) + + +c cas ou on a un extremum au pole + +c if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +c & appn=0. +c if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +c & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +c & apps=0. + +c limitation des pentes aux poles +c do ij=1,iip1 +c dyq(ij)=appn*dyq(ij) +c dyq(ip1jm+ij)=apps*dyq(ip1jm+ij) +c enddo + +c test +c do ij=1,iip1 +c dyq(iip1+ij)=0. +c dyq(ip1jm+ij-iip1)=0. +c enddo +c do ij=1,ip1jmp1 +c dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +c enddo + + if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) + & then + do ij=1,iip1 + dyqmax(ij)=0. + enddo + else + do ij=1,iip1 + dyqmax(ij)=pente_max*abs(dyqv(ij)) + enddo + endif + + if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* + & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) + &then + do ij=ip1jm+1,ip1jmp1 + dyqmax(ij)=0. + enddo + else + do ij=ip1jm+1,ip1jmp1 + dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) + enddo + endif + +c calcul des pentes limitees + + do ij=1,ip1jmp1 + if(dyqv(ij)*dyqv(ij-iip1).gt.0.) then + dyq(ij)=sign(min(abs(dyq(ij)),dyqmax(ij)),dyq(ij)) + else + dyq(ij)=0. + endif + enddo + + DO ij=1,ip1jmp1 + sy(ij,l) = dyq(ij) * sm ( ij,l ) + ENDDO + + enddo ! fin de la boucle sur les couches verticales + + RETURN + END Index: LMDZ5/trunk/libf/dyn3d_common/limz.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/limz.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/limz.F (revision 1952) @@ -0,0 +1,99 @@ +! +! $Header$ +! + SUBROUTINE limz(s0,sz,sm,pente_max) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + real pente_max + REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm) + real sz(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju + integer n0,iadvplus(ip1jmp1,llm),nl(llm) +c + REAL q(ip1jmp1,llm) + real dzq(ip1jmp1,llm) + + + REAL new_m,zm + real dzqw(ip1jmp1) + real adzqw(ip1jmp1),dzqmax(ip1jmp1) + + Logical extremum,first + save first + + REAL SSUM,CVMGP,CVMGT + integer ismax,ismin + EXTERNAL SSUM, ismin,ismax + + data first/.true./ + + + DO l = 1,llm + DO ij=1,ip1jmp1 + q(ij,l) = s0(ij,l) / sm ( ij,l ) + dzq(ij,l) = sz(ij,l) /sm(ij,l) + ENDDO + ENDDO + +c calcul de la pente en haut et en bas de la maille + do ij=1,ip1jmp1 + do l = 1, llm-1 + dzqw(l)=q(ij,l+1)-q(ij,l) + enddo + dzqw(llm)=0. + + do l=1,llm + adzqw(l)=abs(dzqw(l)) + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do l=2,llm-1 + dzqmax(l)=pente_max*min(adzqw(l-1),adzqw(l)) + enddo + +c calcul de la pente avec limitation + + do l=2,llm-1 + if( dzqw(l-1)*dzqw(l).gt.0. + & .and. dzq(ij,l)*dzqw(l).gt.0.) then + dzq(ij,l)= + & sign(min(abs(dzq(ij,l)),dzqmax(l)),dzq(ij,l)) + else +c extremum local + dzq(ij,l)=0. + endif + enddo + + DO l=1,llm + sz(ij,l) = dzq(ij,l)*sm(ij,l) + ENDDO + + ENDDO + + RETURN + END Index: LMDZ5/trunk/libf/dyn3d_common/pentes_ini.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/pentes_ini.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/pentes_ini.F (revision 1952) @@ -0,0 +1,478 @@ +! +! $Header$ +! + SUBROUTINE pentes_ini (q,w,masse,pbaru,pbarv,mode) + IMPLICIT NONE + +c======================================================================= +c Adaptation LMDZ: A.Armengaud (LGGE) +c ---------------- +c +c ******************************************************************** +c Transport des traceurs par la methode des pentes +c ******************************************************************** +c Reference possible : Russel. G.L., Lerner J.A.: +c A new Finite-Differencing Scheme for Traceur Transport +c Equation , Journal of Applied Meteorology, pp 1483-1498,dec. 81 +c ******************************************************************** +c q,w,masse,pbaru et pbarv +c sont des arguments d'entree pour le s-pg .... +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments: +c ---------- + integer mode + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL q( iip1,jjp1,llm,0:3) + REAL w( ip1jmp1,llm ) + REAL masse( iip1,jjp1,llm) +c Local: +c ------ + LOGICAL limit + REAL sm ( iip1,jjp1, llm ) + REAL s0( iip1,jjp1,llm ), sx( iip1,jjp1,llm ) + REAL sy( iip1,jjp1,llm ), sz( iip1,jjp1,llm ) + real masn,mass,zz + INTEGER i,j,l,iq + +c modif Fred 24 03 96 + + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + save sinlon,coslon,sinlondlon,coslondlon + real dyn1,dyn2,dys1,dys2 + real qpn,qps,dqzpn,dqzps + real smn,sms,s0n,s0s,sxn(iip1),sxs(iip1) + real qmin,zq,pente_max +c + REAL SSUM + integer ismax,ismin,lati,latf + EXTERNAL SSUM, ismin,ismax + logical first + save first +c fin modif + +c EXTERNAL masskg + EXTERNAL advx + EXTERNAL advy + EXTERNAL advz + +c modif Fred 24 03 96 + data first/.true./ + + limit = .TRUE. + pente_max=2 +c if (mode.eq.1.or.mode.eq.3) then +c if (mode.eq.1) then + if (mode.ge.1) then + lati=2 + latf=jjm + else + lati=1 + latf=jjp1 + endif + + qmin=0.4995 + qmin=0. + if(first) then + print*,'SCHEMA AMONT NOUVEAU' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + print*,coslondlon(i),sinlondlon(i) + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + print*,'sum sinlondlon ',ssum(iim,sinlondlon,1)/sinlondlon(1) + print*,'sum coslondlon ',ssum(iim,coslondlon,1)/coslondlon(1) + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q ( i,j,l,1 )=0. + q ( i,j,l,2 )=0. + q ( i,j,l,3 )=0. + ENDDO + ENDDO + ENDDO + + endif +c Fin modif Fred + +c *** q contient les qqtes de traceur avant l'advection + +c *** Affectation des tableaux S a partir de Q +c *** Rem : utilisation de SCOPY ulterieurement + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0( i,j,llm+1-l ) = q ( i,j,l,0 ) + sx( i,j,llm+1-l ) = q ( i,j,l,1 ) + sy( i,j,llm+1-l ) = q ( i,j,l,2 ) + sz( i,j,llm+1-l ) = q ( i,j,l,3 ) + ENDDO + ENDDO + ENDDO + +c PRINT*,'----- S0 just before conversion -------' +c PRINT*,'S0(16,12,1)=',s0(16,12,1) +c PRINT*,'Q(16,12,1,4)=',q(16,12,1,4) + +c *** On calcule la masse d'air en kg + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + sm ( i,j,llm+1-l)=masse( i,j,l ) + ENDDO + ENDDO + ENDDO + +c *** On converti les champs S en atome (resp. kg) +c *** Les routines d'advection traitent les champs +c *** a advecter si ces derniers sont en atome (resp. kg) +c *** A optimiser !!! + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0(i,j,l) = s0(i,j,l) * sm ( i,j,l ) + sx(i,j,l) = sx(i,j,l) * sm ( i,j,l ) + sy(i,j,l) = sy(i,j,l) * sm ( i,j,l ) + sz(i,j,l) = sz(i,j,l) * sm ( i,j,l ) + ENDDO + ENDDO + ENDDO + +c ss0 = 0. +c DO l = 1,llm +c DO j = 1,jjp1 +c DO i = 1,iim +c ss0 = ss0 + s0 ( i,j,l ) +c ENDDO +c ENDDO +c ENDDO +c PRINT*, 'valeur tot s0 avant advection=',ss0 + +c *** Appel des subroutines d'advection en X, en Y et en Z +c *** Advection avec "time-splitting" + +c----------------------------------------------------------- +c PRINT*,'----- S0 just before ADVX -------' +c PRINT*,'S0(16,12,1)=',s0(16,12,1) + +c----------------------------------------------------------- +c do l=1,llm +c do j=1,jjp1 +c do i=1,iip1 +c zq=s0(i,j,l)/sm(i,j,l) +c if(zq.lt.qmin) +c , print*,'avant advx1, s0(',i,',',j,',',l,')=',zq +c enddo +c enddo +c enddo +CCC + if(mode.eq.2) then + do l=1,llm + s0s=0. + s0n=0. + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + smn=0. + sms=0. + do i=1,iim + smn=smn+sm(i,1,l) + sms=sms+sm(i,jjp1,l) + s0n=s0n+s0(i,1,l) + s0s=s0s+s0(i,jjp1,l) + zz=sy(i,1,l)/sm(i,1,l) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=sy(i,jjp1,l)/sm(i,jjp1,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + sy(i,1,l)=dyn1*sinlon(i)+dyn2*coslon(i) + sy(i,jjp1,l)=dys1*sinlon(i)+dys2*coslon(i) + enddo + do i=1,iim + s0(i,1,l)=s0n/smn+sy(i,1,l) + s0(i,jjp1,l)=s0s/sms-sy(i,jjp1,l) + enddo + + s0(iip1,1,l)=s0(1,1,l) + s0(iip1,jjp1,l)=s0(1,jjp1,l) + + do i=1,iim + sxn(i)=s0(i+1,1,l)-s0(i,1,l) + sxs(i)=s0(i+1,jjp1,l)-s0(i,jjp1,l) +c on rerentre les masses + enddo + do i=1,iim + sy(i,1,l)=sy(i,1,l)*sm(i,1,l) + sy(i,jjp1,l)=sy(i,jjp1,l)*sm(i,jjp1,l) + s0(i,1,l)=s0(i,1,l)*sm(i,1,l) + s0(i,jjp1,l)=s0(i,jjp1,l)*sm(i,jjp1,l) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + sx(i+1,1,l)=0.25*(sxn(i)+sxn(i+1))*sm(i+1,1,l) + sx(i+1,jjp1,l)=0.25*(sxs(i)+sxs(i+1))*sm(i+1,jjp1,l) + enddo + s0(iip1,1,l)=s0(1,1,l) + s0(iip1,jjp1,l)=s0(1,jjp1,l) + sy(iip1,1,l)=sy(1,1,l) + sy(iip1,jjp1,l)=sy(1,jjp1,l) + sx(1,1,l)=sx(iip1,1,l) + sx(1,jjp1,l)=sx(iip1,jjp1,l) + enddo + endif + + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limx(s0,sx,sm,pente_max) +c call minmaxq(zq,1.e33,-1.e33,'avant advx ') + call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) +c call minmaxq(zq,1.e33,-1.e33,'avant advy ') + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limy(s0,sy,sm,pente_max) + call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) +c call minmaxq(zq,1.e33,-1.e33,'avant advz ') + do j=1,jjp1 + do i=1,iip1 + sz(i,j,1)=0. + sz(i,j,llm)=0. + enddo + enddo + call limz(s0,sz,sm,pente_max) + call advz( limit,dtvr,w,sm,s0,sx,sy,sz ) + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limy(s0,sy,sm,pente_max) + call advy( limit,.5*dtvr,pbarv,sm,s0,sx,sy,sz ) + do l=1,llm + do j=1,jjp1 + sm(iip1,j,l)=sm(1,j,l) + s0(iip1,j,l)=s0(1,j,l) + sx(iip1,j,l)=sx(1,j,l) + sy(iip1,j,l)=sy(1,j,l) + sz(iip1,j,l)=sz(1,j,l) + enddo + enddo + + +c call minmaxq(zq,1.e33,-1.e33,'avant advx ') + if (mode.eq.4) then + do l=1,llm + do i=1,iip1 + sx(i,1,l)=0. + sx(i,jjp1,l)=0. + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + endif + call limx(s0,sx,sm,pente_max) + call advx( limit,.5*dtvr,pbaru,sm,s0,sx,sy,sz,lati,latf) +c call minmaxq(zq,1.e33,-1.e33,'apres advx ') +c do l=1,llm +c do j=1,jjp1 +c do i=1,iip1 +c zq=s0(i,j,l)/sm(i,j,l) +c if(zq.lt.qmin) +c , print*,'apres advx2, s0(',i,',',j,',',l,')=',zq +c enddo +c enddo +c enddo +c *** On repasse les S dans la variable q directement 14/10/94 +c On revient a des rapports de melange en divisant par la masse + +c En dehors des poles: + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + q(i,j,llm+1-l,0)=s0(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,1)=sx(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,2)=sy(i,j,l)/sm(i,j,l) + q(i,j,llm+1-l,3)=sz(i,j,l)/sm(i,j,l) + ENDDO + ENDDO + ENDDO + +c Traitements specifiques au pole + + if(mode.ge.1) then + DO l=1,llm +c filtrages aux poles + masn=ssum(iim,sm(1,1,l),1) + mass=ssum(iim,sm(1,jjp1,l),1) + qpn=ssum(iim,s0(1,1,l),1)/masn + qps=ssum(iim,s0(1,jjp1,l),1)/mass + dqzpn=ssum(iim,sz(1,1,l),1)/masn + dqzps=ssum(iim,sz(1,jjp1,l),1)/mass + do i=1,iip1 + q( i,1,llm+1-l,3)=dqzpn + q( i,jjp1,llm+1-l,3)=dqzps + q( i,1,llm+1-l,0)=qpn + q( i,jjp1,llm+1-l,0)=qps + enddo + if(mode.eq.3) then + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + dyn1=dyn1+sinlondlon(i)*sy(i,1,l)/sm(i,1,l) + dyn2=dyn2+coslondlon(i)*sy(i,1,l)/sm(i,1,l) + dys1=dys1+sinlondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l) + dys2=dys2+coslondlon(i)*sy(i,jjp1,l)/sm(i,jjp1,l) + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + s (sinlon(i)*dyn1+coslon(i)*dyn2) + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + s (sinlon(i)*dys1+coslon(i)*dys2) + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + s -q(i,jjp1,llm+1-l,2) + enddo + endif + if(mode.eq.1) then +c on filtre les valeurs au bord de la "grande maille pole" + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + s (sinlon(i)*dyn1+coslon(i)*dyn2)/2. + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0)+q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + s (sinlon(i)*dys1+coslon(i)*dys2)/2. + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + s -q(i,jjp1,llm+1-l,2) + enddo + q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0) + q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0) + + do i=1,iim + sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0) + sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1)) + q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1)) + enddo + q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1) + q(1,jjp1,llm+1-l,1)=q(iip1,jjp1,llm+1-l,1) + + endif + + ENDDO + endif + +c bouclage en longitude + do iq=0,3 + do l=1,llm + do j=1,jjp1 + q(iip1,j,l,iq)=q(1,j,l,iq) + enddo + enddo + enddo + +c PRINT*, ' SORTIE DE PENTES --- ca peut glisser ....' + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + IF (q(i,j,l,0).lt.0.) THEN +c PRINT*,'------------ BIP-----------' +c PRINT*,'Q0(',i,j,l,')=',q(i,j,l,0) +c PRINT*,'QX(',i,j,l,')=',q(i,j,l,1) +c PRINT*,'QY(',i,j,l,')=',q(i,j,l,2) +c PRINT*,'QZ(',i,j,l,')=',q(i,j,l,3) +c PRINT*,' PBL EN SORTIE DE PENTES' + q(i,j,l,0)=0. +c STOP + ENDIF + ENDDO + ENDDO + ENDDO + +c PRINT*, '-------------------------------------------' + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + if(q(i,j,l,0).lt.qmin) + , print*,'apres pentes, s0(',i,',',j,',',l,')=',q(i,j,l,0) + enddo + enddo + enddo + RETURN + END + + + + + + + + + + + + Index: LMDZ5/trunk/libf/dyn3d_common/ppm3d.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/ppm3d.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/ppm3d.F (revision 1952) @@ -0,0 +1,2001 @@ +! +! $Id$ +! + +cFrom lin@explorer.gsfc.nasa.gov Wed Apr 15 17:44:44 1998 +cDate: Wed, 15 Apr 1998 11:37:03 -0400 +cFrom: lin@explorer.gsfc.nasa.gov +cTo: Frederic.Hourdin@lmd.jussieu.fr +cSubject: 3D transport module of the GSFC CTM and GEOS GCM + + +cThis code is sent to you by S-J Lin, DAO, NASA-GSFC + +cNote: this version is intended for machines like CRAY +C-90. No multitasking directives implemented. + + +C ******************************************************************** +C +C TransPort Core for Goddard Chemistry Transport Model (G-CTM), Goddard +C Earth Observing System General Circulation Model (GEOS-GCM), and Data +C Assimilation System (GEOS-DAS). +C +C ******************************************************************** +C +C Purpose: given horizontal winds on a hybrid sigma-p surfaces, +C one call to tpcore updates the 3-D mixing ratio +C fields one time step (NDT). [vertical mass flux is computed +C internally consistent with the discretized hydrostatic mass +C continuity equation of the C-Grid GEOS-GCM (for IGD=1)]. +C +C Schemes: Multi-dimensional Flux Form Semi-Lagrangian (FFSL) scheme based +C on the van Leer or PPM. +C (see Lin and Rood 1996). +C Version 4.5 +C Last modified: Dec. 5, 1996 +C Major changes from version 4.0: a more general vertical hybrid sigma- +C pressure coordinate. +C Subroutines modified: xtp, ytp, fzppm, qckxyz +C Subroutines deleted: vanz +C +C Author: Shian-Jiann Lin +C mail address: +C Shian-Jiann Lin* +C Code 910.3, NASA/GSFC, Greenbelt, MD 20771 +C Phone: 301-286-9540 +C E-mail: lin@dao.gsfc.nasa.gov +C +C *affiliation: +C Joint Center for Earth Systems Technology +C The University of Maryland Baltimore County +C NASA - Goddard Space Flight Center +C References: +C +C 1. Lin, S.-J., and R. B. Rood, 1996: Multidimensional flux form semi- +C Lagrangian transport schemes. Mon. Wea. Rev., 124, 2046-2070. +C +C 2. Lin, S.-J., W. C. Chao, Y. C. Sud, and G. K. Walker, 1994: A class of +C the van Leer-type transport schemes and its applications to the moist- +C ure transport in a General Circulation Model. Mon. Wea. Rev., 122, +C 1575-1593. +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C + subroutine ppm3d(IGD,Q,PS1,PS2,U,V,W,NDT,IORD,JORD,KORD,NC,IMR, + & JNP,j1,NLAY,AP,BP,PT,AE,fill,dum,Umax) + +c implicit none + +c rajout de déclarations +c integer Jmax,kmax,ndt0,nstep,k,j,i,ic,l,js,jn,imh,iad,jad,krd +c integer iu,iiu,j2,jmr,js0,jt +c real dtdy,dtdy5,rcap,iml,jn0,imjm,pi,dl,dp +c real dt,cr1,maxdt,ztc,d5,sum1,sum2,ru +C +C ******************************************************************** +C +C ============= +C INPUT: +C ============= +C +C Q(IMR,JNP,NLAY,NC): mixing ratios at current time (t) +C NC: total # of constituents +C IMR: first dimension (E-W); # of Grid intervals in E-W is IMR +C JNP: 2nd dimension (N-S); # of Grid intervals in N-S is JNP-1 +C NLAY: 3rd dimension (# of layers); vertical index increases from 1 at +C the model top to NLAY near the surface (see fig. below). +C It is assumed that 6 <= NLAY <= JNP (for dynamic memory allocation) +C +C PS1(IMR,JNP): surface pressure at current time (t) +C PS2(IMR,JNP): surface pressure at mid-time-level (t+NDT/2) +C PS2 is replaced by the predicted PS (at t+NDT) on output. +C Note: surface pressure can have any unit or can be multiplied by any +C const. +C +C The pressure at layer edges are defined as follows: +C +C p(i,j,k) = AP(k)*PT + BP(k)*PS(i,j) (1) +C +C Where PT is a constant having the same unit as PS. +C AP and BP are unitless constants given at layer edges +C defining the vertical coordinate. +C BP(1) = 0., BP(NLAY+1) = 1. +C The pressure at the model top is PTOP = AP(1)*PT +C +C For pure sigma system set AP(k) = 1 for all k, PT = PTOP, +C BP(k) = sige(k) (sigma at edges), PS = Psfc - PTOP. +C +C Note: the sigma-P coordinate is a subset of Eq. 1, which in turn +C is a subset of the following even more general sigma-P-thelta coord. +C currently under development. +C p(i,j,k) = (AP(k)*PT + BP(k)*PS(i,j))/(D(k)-C(k)*TE**(-1/kapa)) +C +C ///////////////////////////////// +C / \ ------------- PTOP -------------- AP(1), BP(1) +C | +C delp(1) | ........... Q(i,j,1) ............ +C | +C W(1) \ / --------------------------------- AP(2), BP(2) +C +C +C +C W(k-1) / \ --------------------------------- AP(k), BP(k) +C | +C delp(K) | ........... Q(i,j,k) ............ +C | +C W(k) \ / --------------------------------- AP(k+1), BP(k+1) +C +C +C +C / \ --------------------------------- AP(NLAY), BP(NLAY) +C | +C delp(NLAY) | ........... Q(i,j,NLAY) ......... +C | +C W(NLAY)=0 \ / ------------- surface ----------- AP(NLAY+1), BP(NLAY+1) +C ////////////////////////////////// +C +C U(IMR,JNP,NLAY) & V(IMR,JNP,NLAY):winds (m/s) at mid-time-level (t+NDT/2) +C U and V may need to be polar filtered in advance in some cases. +C +C IGD: grid type on which winds are defined. +C IGD = 0: A-Grid [all variables defined at the same point from south +C pole (j=1) to north pole (j=JNP) ] +C +C IGD = 1 GEOS-GCM C-Grid +C [North] +C +C V(i,j) +C | +C | +C | +C U(i-1,j)---Q(i,j)---U(i,j) [EAST] +C | +C | +C | +C V(i,j-1) +C +C U(i, 1) is defined at South Pole. +C V(i, 1) is half grid north of the South Pole. +C V(i,JMR) is half grid south of the North Pole. +C +C V must be defined at j=1 and j=JMR if IGD=1 +C V at JNP need not be given. +C +C NDT: time step in seconds (need not be constant during the course of +C the integration). Suggested value: 30 min. for 4x5, 15 min. for 2x2.5 +C (Lat-Lon) resolution. Smaller values are recommanded if the model +C has a well-resolved stratosphere. +C +C J1 defines the size of the polar cap: +C South polar cap edge is located at -90 + (j1-1.5)*180/(JNP-1) deg. +C North polar cap edge is located at 90 - (j1-1.5)*180/(JNP-1) deg. +C There are currently only two choices (j1=2 or 3). +C IMR must be an even integer if j1 = 2. Recommended value: J1=3. +C +C IORD, JORD, and KORD are integers controlling various options in E-W, N-S, +C and vertical transport, respectively. Recommended values for positive +C definite scalars: IORD=JORD=3, KORD=5. Use KORD=3 for non- +C positive definite scalars or when linear correlation between constituents +C is to be maintained. +C +C _ORD= +C 1: 1st order upstream scheme (too diffusive, not a useful option; it +C can be used for debugging purposes; this is THE only known "linear" +C monotonic advection scheme.). +C 2: 2nd order van Leer (full monotonicity constraint; +C see Lin et al 1994, MWR) +C 3: monotonic PPM* (slightly improved PPM of Collela & Woodward 1984) +C 4: semi-monotonic PPM (same as 3, but overshoots are allowed) +C 5: positive-definite PPM (constraint on the subgrid distribution is +C only strong enough to prevent generation of negative values; +C both overshoots & undershoots are possible). +C 6: un-constrained PPM (nearly diffusion free; slightly faster but +C positivity not quaranteed. Use this option only when the fields +C and winds are very smooth). +C +C *PPM: Piece-wise Parabolic Method +C +C Note that KORD <=2 options are no longer supported. DO not use option 4 or 5. +C for non-positive definite scalars (such as Ertel Potential Vorticity). +C +C The implicit numerical diffusion decreases as _ORD increases. +C The last two options (ORDER=5, 6) should only be used when there is +C significant explicit diffusion (such as a turbulence parameterization). You +C might get dispersive results otherwise. +C No filter of any kind is applied to the constituent fields here. +C +C AE: Radius of the sphere (meters). +C Recommended value for the planet earth: 6.371E6 +C +C fill(logical): flag to do filling for negatives (see note below). +C +C Umax: Estimate (upper limit) of the maximum U-wind speed (m/s). +C (220 m/s is a good value for troposphere model; 280 m/s otherwise) +C +C ============= +C Output +C ============= +C +C Q: mixing ratios at future time (t+NDT) (original values are over-written) +C W(NLAY): large-scale vertical mass flux as diagnosed from the hydrostatic +C relationship. W will have the same unit as PS1 and PS2 (eg, mb). +C W must be divided by NDT to get the correct mass-flux unit. +C The vertical Courant number C = W/delp_UPWIND, where delp_UPWIND +C is the pressure thickness in the "upwind" direction. For example, +C C(k) = W(k)/delp(k) if W(k) > 0; +C C(k) = W(k)/delp(k+1) if W(k) < 0. +C ( W > 0 is downward, ie, toward surface) +C PS2: predicted PS at t+NDT (original values are over-written) +C +C ******************************************************************** +C NOTES: +C This forward-in-time upstream-biased transport scheme reduces to +C the 2nd order center-in-time center-in-space mass continuity eqn. +C if Q = 1 (constant fields will remain constant). This also ensures +C that the computed vertical velocity to be identical to GEOS-1 GCM +C for on-line transport. +C +C A larger polar cap is used if j1=3 (recommended for C-Grid winds or when +C winds are noisy near poles). +C +C Flux-Form Semi-Lagrangian transport in the East-West direction is used +C when and where Courant # is greater than one. +C +C The user needs to change the parameter Jmax or Kmax if the resolution +C is greater than 0.5 deg in N-S or 150 layers in the vertical direction. +C (this TransPort Core is otherwise resolution independent and can be used +C as a library routine). +C +C PPM is 4th order accurate when grid spacing is uniform (x & y); 3rd +C order accurate for non-uniform grid (vertical sigma coord.). +C +C Time step is limitted only by transport in the meridional direction. +C (the FFSL scheme is not implemented in the meridional direction). +C +C Since only 1-D limiters are applied, negative values could +C potentially be generated when large time step is used and when the +C initial fields contain discontinuities. +C This does not necessarily imply the integration is unstable. +C These negatives are typically very small. A filling algorithm is +C activated if the user set "fill" to be true. +C +C The van Leer scheme used here is nearly as accurate as the original PPM +C due to the use of a 4th order accurate reference slope. The PPM imple- +C mented here is an improvement over the original and is also based on +C the 4th order reference slope. +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C User modifiable parameters +C + parameter (Jmax = 361, kmax = 150) +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C Input-Output arrays +C + + real Q(IMR,JNP,NLAY,NC),PS1(IMR,JNP),PS2(IMR,JNP), + & U(IMR,JNP,NLAY),V(IMR,JNP,NLAY),AP(NLAY+1), + & BP(NLAY+1),W(IMR,JNP,NLAY),NDT,val(NLAY),Umax + integer IGD,IORD,JORD,KORD,NC,IMR,JNP,j1,NLAY,AE + integer IMRD2 + real PT + logical cross, fill, dum +C +C Local dynamic arrays +C + real CRX(IMR,JNP),CRY(IMR,JNP),xmass(IMR,JNP),ymass(IMR,JNP), + & fx1(IMR+1),DPI(IMR,JNP,NLAY),delp1(IMR,JNP,NLAY), + & WK1(IMR,JNP,NLAY),PU(IMR,JNP),PV(IMR,JNP),DC2(IMR,JNP), + & delp2(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY,NC),VA(IMR,JNP), + & UA(IMR,JNP),qtmp(-IMR:2*IMR) +C +C Local static arrays +C + real DTDX(Jmax), DTDX5(Jmax), acosp(Jmax), + & cosp(Jmax), cose(Jmax), DAP(kmax),DBK(Kmax) + data NDT0, NSTEP /0, 0/ + data cross /.true./ + SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML, + & DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK +C + + JMR = JNP -1 + IMJM = IMR*JNP + j2 = JNP - j1 + 1 + NSTEP = NSTEP + 1 +C +C *********** Initialization ********************** + if(NSTEP.eq.1) then +c + write(6,*) '------------------------------------ ' + write(6,*) 'NASA/GSFC Transport Core Version 4.5' + write(6,*) '------------------------------------ ' +c + WRITE(6,*) 'IMR=',IMR,' JNP=',JNP,' NLAY=',NLAY,' j1=',j1 + WRITE(6,*) 'NC=',NC,IORD,JORD,KORD,NDT +C +C controles sur les parametres + if(NLAY.LT.6) then + write(6,*) 'NLAY must be >= 6' + stop + endif + if (JNP.LT.NLAY) then + write(6,*) 'JNP must be >= NLAY' + stop + endif + IMRD2=mod(IMR,2) + if (j1.eq.2.and.IMRD2.NE.0) then + write(6,*) 'if j1=2 IMR must be an even integer' + stop + endif + +C + if(Jmax.lt.JNP .or. Kmax.lt.NLAY) then + write(6,*) 'Jmax or Kmax is too small' + stop + endif +C + DO k=1,NLAY + DAP(k) = (AP(k+1) - AP(k))*PT + DBK(k) = BP(k+1) - BP(k) + ENDDO +C + PI = 4. * ATAN(1.) + DL = 2.*PI / REAL(IMR) + DP = PI / REAL(JMR) +C + if(IGD.eq.0) then +C Compute analytic cosine at cell edges + call cosa(cosp,cose,JNP,PI,DP) + else +C Define cosine consistent with GEOS-GCM (using dycore2.0 or later) + call cosc(cosp,cose,JNP,PI,DP) + endif +C + do 15 J=2,JMR +15 acosp(j) = 1. / cosp(j) +C +C Inverse of the Scaled polar cap area. +C + RCAP = DP / (IMR*(1.-COS((j1-1.5)*DP))) + acosp(1) = RCAP + acosp(JNP) = RCAP + endif +C + if(NDT0 .ne. NDT) then + DT = NDT + NDT0 = NDT + + if(Umax .lt. 180.) then + write(6,*) 'Umax may be too small!' + endif + CR1 = abs(Umax*DT)/(DL*AE) + MaxDT = DP*AE / abs(Umax) + 0.5 + write(6,*)'Largest time step for max(V)=',Umax,' is ',MaxDT + if(MaxDT .lt. abs(NDT)) then + write(6,*) 'Warning!!! NDT maybe too large!' + endif +C + if(CR1.ge.0.95) then + JS0 = 0 + JN0 = 0 + IML = IMR-2 + ZTC = 0. + else + ZTC = acos(CR1) * (180./PI) +C + JS0 = REAL(JMR)*(90.-ZTC)/180. + 2 + JS0 = max(JS0, J1+1) + IML = min(6*JS0/(J1-1)+2, 4*IMR/5) + JN0 = JNP-JS0+1 + endif +C +C + do J=2,JMR + DTDX(j) = DT / ( DL*AE*COSP(J) ) + +c print*,'dtdx=',dtdx(j) + DTDX5(j) = 0.5*DTDX(j) + enddo +C + + DTDY = DT /(AE*DP) +c print*,'dtdy=',dtdy + DTDY5 = 0.5*DTDY +C +c write(6,*) 'J1=',J1,' J2=', J2 + endif +C +C *********** End Initialization ********************** +C +C delp = pressure thickness: the psudo-density in a hydrostatic system. + do k=1,NLAY + do j=1,JNP + do i=1,IMR + delp1(i,j,k)=DAP(k)+DBK(k)*PS1(i,j) + delp2(i,j,k)=DAP(k)+DBK(k)*PS2(i,j) + enddo + enddo + enddo + +C + if(j1.ne.2) then + DO 40 IC=1,NC + DO 40 L=1,NLAY + DO 40 I=1,IMR + Q(I, 2,L,IC) = Q(I, 1,L,IC) +40 Q(I,JMR,L,IC) = Q(I,JNP,L,IC) + endif +C +C Compute "tracer density" + DO 550 IC=1,NC + DO 44 k=1,NLAY + DO 44 j=1,JNP + DO 44 i=1,IMR +44 DQ(i,j,k,IC) = Q(i,j,k,IC)*delp1(i,j,k) +550 continue +C + do 1500 k=1,NLAY +C + if(IGD.eq.0) then +C Convert winds on A-Grid to Courant # on C-Grid. + call A2C(U(1,1,k),V(1,1,k),IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5) + else +C Convert winds on C-grid to Courant # + do 45 j=j1,j2 + do 45 i=2,IMR +45 CRX(i,J) = dtdx(j)*U(i-1,j,k) + +C + do 50 j=j1,j2 +50 CRX(1,J) = dtdx(j)*U(IMR,j,k) +C + do 55 i=1,IMR*JMR +55 CRY(i,2) = DTDY*V(i,1,k) + endif +C +C Determine JS and JN + JS = j1 + JN = j2 +C + do j=JS0,j1+1,-1 + do i=1,IMR + if(abs(CRX(i,j)).GT.1.) then + JS = j + go to 2222 + endif + enddo + enddo +C +2222 continue + do j=JN0,j2-1 + do i=1,IMR + if(abs(CRX(i,j)).GT.1.) then + JN = j + go to 2233 + endif + enddo + enddo +2233 continue +C + if(j1.ne.2) then ! Enlarged polar cap. + do i=1,IMR + DPI(i, 2,k) = 0. + DPI(i,JMR,k) = 0. + enddo + endif +C +C ******* Compute horizontal mass fluxes ************ +C +C N-S component + do j=j1,j2+1 + D5 = 0.5 * COSE(j) + do i=1,IMR + ymass(i,j) = CRY(i,j)*D5*(delp2(i,j,k) + delp2(i,j-1,k)) + enddo + enddo +C + do 95 j=j1,j2 + DO 95 i=1,IMR +95 DPI(i,j,k) = (ymass(i,j) - ymass(i,j+1)) * acosp(j) +C +C Poles + sum1 = ymass(IMR,j1 ) + sum2 = ymass(IMR,J2+1) + do i=1,IMR-1 + sum1 = sum1 + ymass(i,j1 ) + sum2 = sum2 + ymass(i,J2+1) + enddo +C + sum1 = - sum1 * RCAP + sum2 = sum2 * RCAP + do i=1,IMR + DPI(i, 1,k) = sum1 + DPI(i,JNP,k) = sum2 + enddo +C +C E-W component +C + do j=j1,j2 + do i=2,IMR + PU(i,j) = 0.5 * (delp2(i,j,k) + delp2(i-1,j,k)) + enddo + enddo +C + do j=j1,j2 + PU(1,j) = 0.5 * (delp2(1,j,k) + delp2(IMR,j,k)) + enddo +C + do 110 j=j1,j2 + DO 110 i=1,IMR +110 xmass(i,j) = PU(i,j)*CRX(i,j) +C + DO 120 j=j1,j2 + DO 120 i=1,IMR-1 +120 DPI(i,j,k) = DPI(i,j,k) + xmass(i,j) - xmass(i+1,j) +C + DO 130 j=j1,j2 +130 DPI(IMR,j,k) = DPI(IMR,j,k) + xmass(IMR,j) - xmass(1,j) +C + DO j=j1,j2 + do i=1,IMR-1 + UA(i,j) = 0.5 * (CRX(i,j)+CRX(i+1,j)) + enddo + enddo +C + DO j=j1,j2 + UA(imr,j) = 0.5 * (CRX(imr,j)+CRX(1,j)) + enddo +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Rajouts pour LMDZ.3.3 +ccccccccccccccccccccccccccccccccccccccccccccccccccccccc + do i=1,IMR + do j=1,JNP + VA(i,j)=0. + enddo + enddo + + do i=1,imr*(JMR-1) + VA(i,2) = 0.5*(CRY(i,2)+CRY(i,3)) + enddo +C + if(j1.eq.2) then + IMH = IMR/2 + do i=1,IMH + VA(i, 1) = 0.5*(CRY(i,2)-CRY(i+IMH,2)) + VA(i+IMH, 1) = -VA(i,1) + VA(i, JNP) = 0.5*(CRY(i,JNP)-CRY(i+IMH,JMR)) + VA(i+IMH,JNP) = -VA(i,JNP) + enddo + VA(IMR,1)=VA(1,1) + VA(IMR,JNP)=VA(1,JNP) + endif +C +C ****6***0*********0*********0*********0*********0*********0**********72 + do 1000 IC=1,NC +C + do i=1,IMJM + wk1(i,1,1) = 0. + wk1(i,1,2) = 0. + enddo +C +C E-W advective cross term + do 250 j=J1,J2 + if(J.GT.JS .and. J.LT.JN) GO TO 250 +C + do i=1,IMR + qtmp(i) = q(i,j,k,IC) + enddo +C + do i=-IML,0 + qtmp(i) = q(IMR+i,j,k,IC) + qtmp(IMR+1-i) = q(1-i,j,k,IC) + enddo +C + DO 230 i=1,IMR + iu = UA(i,j) + ru = UA(i,j) - iu + iiu = i-iu + if(UA(i,j).GE.0.) then + wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu)) + else + wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1)) + endif + wk1(i,j,1) = wk1(i,j,1) - qtmp(i) +230 continue +250 continue +C + if(JN.ne.0) then + do j=JS+1,JN-1 +C + do i=1,IMR + qtmp(i) = q(i,j,k,IC) + enddo +C + qtmp(0) = q(IMR,J,k,IC) + qtmp(IMR+1) = q( 1,J,k,IC) +C + do i=1,imr + iu = i - UA(i,j) + wk1(i,j,1) = UA(i,j)*(qtmp(iu) - qtmp(iu+1)) + enddo + enddo + endif +C ****6***0*********0*********0*********0*********0*********0**********72 +C Contribution from the N-S advection + do i=1,imr*(j2-j1+1) + JT = REAL(J1) - VA(i,j1) + wk1(i,j1,2) = VA(i,j1) * (q(i,jt,k,IC) - q(i,jt+1,k,IC)) + enddo +C + do i=1,IMJM + wk1(i,1,1) = q(i,1,k,IC) + 0.5*wk1(i,1,1) + wk1(i,1,2) = q(i,1,k,IC) + 0.5*wk1(i,1,2) + enddo +C + if(cross) then +C Add cross terms in the vertical direction. + if(IORD .GE. 2) then + iad = 2 + else + iad = 1 + endif +C + if(JORD .GE. 2) then + jad = 2 + else + jad = 1 + endif + call xadv(IMR,JNP,j1,j2,wk1(1,1,2),UA,JS,JN,IML,DC2,iad) + call yadv(IMR,JNP,j1,j2,wk1(1,1,1),VA,PV,W,jad) + do j=1,JNP + do i=1,IMR + q(i,j,k,IC) = q(i,j,k,IC) + DC2(i,j) + PV(i,j) + enddo + enddo + endif +C + call xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ(1,1,k,IC),wk1(1,1,2) + & ,CRX,fx1,xmass,IORD) + + call ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ(1,1,k,IC),wk1(1,1,1),CRY, + & DC2,ymass,WK1(1,1,3),wk1(1,1,4),WK1(1,1,5),WK1(1,1,6),JORD) +C +1000 continue +1500 continue +C +C ******* Compute vertical mass flux (same unit as PS) *********** +C +C 1st step: compute total column mass CONVERGENCE. +C + do 320 j=1,JNP + do 320 i=1,IMR +320 CRY(i,j) = DPI(i,j,1) +C + do 330 k=2,NLAY + do 330 j=1,JNP + do 330 i=1,IMR + CRY(i,j) = CRY(i,j) + DPI(i,j,k) +330 continue +C + do 360 j=1,JNP + do 360 i=1,IMR +C +C 2nd step: compute PS2 (PS at n+1) using the hydrostatic assumption. +C Changes (increases) to surface pressure = total column mass convergence +C + PS2(i,j) = PS1(i,j) + CRY(i,j) +C +C 3rd step: compute vertical mass flux from mass conservation principle. +C + W(i,j,1) = DPI(i,j,1) - DBK(1)*CRY(i,j) + W(i,j,NLAY) = 0. +360 continue +C + do 370 k=2,NLAY-1 + do 370 j=1,JNP + do 370 i=1,IMR + W(i,j,k) = W(i,j,k-1) + DPI(i,j,k) - DBK(k)*CRY(i,j) +370 continue +C + DO 380 k=1,NLAY + DO 380 j=1,JNP + DO 380 i=1,IMR + delp2(i,j,k) = DAP(k) + DBK(k)*PS2(i,j) +380 continue +C + KRD = max(3, KORD) + do 4000 IC=1,NC +C +C****6***0*********0*********0*********0*********0*********0**********72 + + call FZPPM(IMR,JNP,NLAY,j1,DQ(1,1,1,IC),W,Q(1,1,1,IC),WK1,DPI, + & DC2,CRX,CRY,PU,PV,xmass,ymass,delp1,KRD) +C + + if(fill) call qckxyz(DQ(1,1,1,IC),DC2,IMR,JNP,NLAY,j1,j2, + & cosp,acosp,.false.,IC,NSTEP) +C +C Recover tracer mixing ratio from "density" using predicted +C "air density" (pressure thickness) at time-level n+1 +C + DO k=1,NLAY + DO j=1,JNP + DO i=1,IMR + Q(i,j,k,IC) = DQ(i,j,k,IC) / delp2(i,j,k) +c print*,'i=',i,'j=',j,'k=',k,'Q(i,j,k,IC)=',Q(i,j,k,IC) + enddo + enddo + enddo +C + if(j1.ne.2) then + DO 400 k=1,NLAY + DO 400 I=1,IMR +c j=1 c'est le pôle Sud, j=JNP c'est le pôle Nord + Q(I, 2,k,IC) = Q(I, 1,k,IC) + Q(I,JMR,k,IC) = Q(I,JNP,k,IC) +400 CONTINUE + endif +4000 continue +C + if(j1.ne.2) then + DO 5000 k=1,NLAY + DO 5000 i=1,IMR + W(i, 2,k) = W(i, 1,k) + W(i,JMR,k) = W(i,JNP,k) +5000 continue + endif +C + RETURN + END +C +C****6***0*********0*********0*********0*********0*********0**********72 + subroutine FZPPM(IMR,JNP,NLAY,j1,DQ,WZ,P,DC,DQDT,AR,AL,A6, + & flux,wk1,wk2,wz2,delp,KORD) + parameter ( kmax = 150 ) + parameter ( R23 = 2./3., R3 = 1./3.) + real WZ(IMR,JNP,NLAY),P(IMR,JNP,NLAY),DC(IMR,JNP,NLAY), + & wk1(IMR,*),delp(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY), + & DQDT(IMR,JNP,NLAY) +C Assuming JNP >= NLAY + real AR(IMR,*),AL(IMR,*),A6(IMR,*),flux(IMR,*),wk2(IMR,*), + & wz2(IMR,*) +C + JMR = JNP - 1 + IMJM = IMR*JNP + NLAYM1 = NLAY - 1 +C + LMT = KORD - 3 +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C Compute DC for PPM +C ****6***0*********0*********0*********0*********0*********0**********72 +C + do 1000 k=1,NLAYM1 + do 1000 i=1,IMJM + DQDT(i,1,k) = P(i,1,k+1) - P(i,1,k) +1000 continue +C + DO 1220 k=2,NLAYM1 + DO 1220 I=1,IMJM + c0 = delp(i,1,k) / (delp(i,1,k-1)+delp(i,1,k)+delp(i,1,k+1)) + c1 = (delp(i,1,k-1)+0.5*delp(i,1,k))/(delp(i,1,k+1)+delp(i,1,k)) + c2 = (delp(i,1,k+1)+0.5*delp(i,1,k))/(delp(i,1,k-1)+delp(i,1,k)) + tmp = c0*(c1*DQDT(i,1,k) + c2*DQDT(i,1,k-1)) + Qmax = max(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) - P(i,1,k) + Qmin = P(i,1,k) - min(P(i,1,k-1),P(i,1,k),P(i,1,k+1)) + DC(i,1,k) = sign(min(abs(tmp),Qmax,Qmin), tmp) +1220 CONTINUE + +C +C ****6***0*********0*********0*********0*********0*********0**********72 +C Loop over latitudes (to save memory) +C ****6***0*********0*********0*********0*********0*********0**********72 +C + DO 2000 j=1,JNP + if((j.eq.2 .or. j.eq.JMR) .and. j1.ne.2) goto 2000 +C + DO k=1,NLAY + DO i=1,IMR + wz2(i,k) = WZ(i,j,k) + wk1(i,k) = P(i,j,k) + wk2(i,k) = delp(i,j,k) + flux(i,k) = DC(i,j,k) !this flux is actually the monotone slope + enddo + enddo +C +C****6***0*********0*********0*********0*********0*********0**********72 +C Compute first guesses at cell interfaces +C First guesses are required to be continuous. +C ****6***0*********0*********0*********0*********0*********0**********72 +C +C three-cell parabolic subgrid distribution at model top +C two-cell parabolic with zero gradient subgrid distribution +C at the surface. +C +C First guess top edge value + DO 10 i=1,IMR +C three-cell PPM +C Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp + a = 3.*( DQDT(i,j,2) - DQDT(i,j,1)*(wk2(i,2)+wk2(i,3))/ + & (wk2(i,1)+wk2(i,2)) ) / + & ( (wk2(i,2)+wk2(i,3))*(wk2(i,1)+wk2(i,2)+wk2(i,3)) ) + b = 2.*DQDT(i,j,1)/(wk2(i,1)+wk2(i,2)) - + & R23*a*(2.*wk2(i,1)+wk2(i,2)) + AL(i,1) = wk1(i,1) - wk2(i,1)*(R3*a*wk2(i,1) + 0.5*b) + AL(i,2) = wk2(i,1)*(a*wk2(i,1) + b) + AL(i,1) +C +C Check if change sign + if(wk1(i,1)*AL(i,1).le.0.) then + AL(i,1) = 0. + flux(i,1) = 0. + else + flux(i,1) = wk1(i,1) - AL(i,1) + endif +10 continue +C +C Bottom + DO 15 i=1,IMR +C 2-cell PPM with zero gradient right at the surface +C + fct = DQDT(i,j,NLAYM1)*wk2(i,NLAY)**2 / + & ( (wk2(i,NLAY)+wk2(i,NLAYM1))*(2.*wk2(i,NLAY)+wk2(i,NLAYM1))) + AR(i,NLAY) = wk1(i,NLAY) + fct + AL(i,NLAY) = wk1(i,NLAY) - (fct+fct) + if(wk1(i,NLAY)*AR(i,NLAY).le.0.) AR(i,NLAY) = 0. + flux(i,NLAY) = AR(i,NLAY) - wk1(i,NLAY) +15 continue + +C +C****6***0*********0*********0*********0*********0*********0**********72 +C 4th order interpolation in the interior. +C****6***0*********0*********0*********0*********0*********0**********72 +C + DO 14 k=3,NLAYM1 + DO 12 i=1,IMR + c1 = DQDT(i,j,k-1)*wk2(i,k-1) / (wk2(i,k-1)+wk2(i,k)) + c2 = 2. / (wk2(i,k-2)+wk2(i,k-1)+wk2(i,k)+wk2(i,k+1)) + A1 = (wk2(i,k-2)+wk2(i,k-1)) / (2.*wk2(i,k-1)+wk2(i,k)) + A2 = (wk2(i,k )+wk2(i,k+1)) / (2.*wk2(i,k)+wk2(i,k-1)) + AL(i,k) = wk1(i,k-1) + c1 + c2 * + & ( wk2(i,k )*(c1*(A1 - A2)+A2*flux(i,k-1)) - + & wk2(i,k-1)*A1*flux(i,k) ) +C print *,'AL1',i,k, AL(i,k) +12 CONTINUE +14 continue +C + do 20 i=1,IMR*NLAYM1 + AR(i,1) = AL(i,2) +C print *,'AR1',i,AR(i,1) +20 continue +C + do 30 i=1,IMR*NLAY + A6(i,1) = 3.*(wk1(i,1)+wk1(i,1) - (AL(i,1)+AR(i,1))) +C print *,'A61',i,A6(i,1) +30 continue +C +C****6***0*********0*********0*********0*********0*********0**********72 +C Top & Bot always monotonic + call lmtppm(flux(1,1),A6(1,1),AR(1,1),AL(1,1),wk1(1,1),IMR,0) + call lmtppm(flux(1,NLAY),A6(1,NLAY),AR(1,NLAY),AL(1,NLAY), + & wk1(1,NLAY),IMR,0) +C +C Interior depending on KORD + if(LMT.LE.2) + & call lmtppm(flux(1,2),A6(1,2),AR(1,2),AL(1,2),wk1(1,2), + & IMR*(NLAY-2),LMT) +C +C****6***0*********0*********0*********0*********0*********0**********72 +C + DO 140 i=1,IMR*NLAYM1 + IF(wz2(i,1).GT.0.) then + CM = wz2(i,1) / wk2(i,1) + flux(i,2) = AR(i,1)+0.5*CM*(AL(i,1)-AR(i,1)+A6(i,1)*(1.-R23*CM)) + else +C print *,'test2-0',i,j,wz2(i,1),wk2(i,2) + CP= wz2(i,1) / wk2(i,2) +C print *,'testCP',CP + flux(i,2) = AL(i,2)+0.5*CP*(AL(i,2)-AR(i,2)-A6(i,2)*(1.+R23*CP)) +C print *,'test2',i, AL(i,2),AR(i,2),A6(i,2),R23 + endif +140 continue +C + DO 250 i=1,IMR*NLAYM1 + flux(i,2) = wz2(i,1) * flux(i,2) +250 continue +C + do 350 i=1,IMR + DQ(i,j, 1) = DQ(i,j, 1) - flux(i, 2) + DQ(i,j,NLAY) = DQ(i,j,NLAY) + flux(i,NLAY) +350 continue +C + do 360 k=2,NLAYM1 + do 360 i=1,IMR +360 DQ(i,j,k) = DQ(i,j,k) + flux(i,k) - flux(i,k+1) +2000 continue + return + end +C + subroutine xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC, + & fx1,xmass,IORD) + dimension UC(IMR,*),DC(-IML:IMR+IML+1),xmass(IMR,JNP) + & ,fx1(IMR+1),DQ(IMR,JNP),qtmp(-IML:IMR+1+IML) + dimension PU(IMR,JNP),Q(IMR,JNP),ISAVE(IMR) +C + IMP = IMR + 1 +C +C van Leer at high latitudes + jvan = max(1,JNP/18) + j1vl = j1+jvan + j2vl = j2-jvan +C + do 1310 j=j1,j2 +C + do i=1,IMR + qtmp(i) = q(i,j) + enddo +C + if(j.ge.JN .or. j.le.JS) goto 2222 +C ************* Eulerian ********** +C + qtmp(0) = q(IMR,J) + qtmp(-1) = q(IMR-1,J) + qtmp(IMP) = q(1,J) + qtmp(IMP+1) = q(2,J) +C + IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN + DO 1406 i=1,IMR + iu = REAL(i) - uc(i,j) +1406 fx1(i) = qtmp(iu) + ELSE + call xmist(IMR,IML,Qtmp,DC) + DC(0) = DC(IMR) +C + if(IORD.eq.2 .or. j.le.j1vl .or. j.ge.j2vl) then + DO 1408 i=1,IMR + iu = REAL(i) - uc(i,j) +1408 fx1(i) = qtmp(iu) + DC(iu)*(sign(1.,uc(i,j))-uc(i,j)) + else + call fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD) + endif +C + ENDIF +C + DO 1506 i=1,IMR +1506 fx1(i) = fx1(i)*xmass(i,j) +C + goto 1309 +C +C ***** Conservative (flux-form) Semi-Lagrangian transport ***** +C +2222 continue +C + do i=-IML,0 + qtmp(i) = q(IMR+i,j) + qtmp(IMP-i) = q(1-i,j) + enddo +C + IF(IORD.eq.1 .or. j.eq.j1. or. j.eq.j2) THEN + DO 1306 i=1,IMR + itmp = INT(uc(i,j)) + ISAVE(i) = i - itmp + iu = i - uc(i,j) +1306 fx1(i) = (uc(i,j) - itmp)*qtmp(iu) + ELSE + call xmist(IMR,IML,Qtmp,DC) +C + do i=-IML,0 + DC(i) = DC(IMR+i) + DC(IMP-i) = DC(1-i) + enddo +C + DO 1307 i=1,IMR + itmp = INT(uc(i,j)) + rut = uc(i,j) - itmp + ISAVE(i) = i - itmp + iu = i - uc(i,j) +1307 fx1(i) = rut*(qtmp(iu) + DC(iu)*(sign(1.,rut) - rut)) + ENDIF +C + do 1308 i=1,IMR + IF(uc(i,j).GT.1.) then +CDIR$ NOVECTOR + do ist = ISAVE(i),i-1 + fx1(i) = fx1(i) + qtmp(ist) + enddo + elseIF(uc(i,j).LT.-1.) then + do ist = i,ISAVE(i)-1 + fx1(i) = fx1(i) - qtmp(ist) + enddo +CDIR$ VECTOR + endif +1308 continue + do i=1,IMR + fx1(i) = PU(i,j)*fx1(i) + enddo +C +C *************************************** +C +1309 fx1(IMP) = fx1(1) + DO 1215 i=1,IMR +1215 DQ(i,j) = DQ(i,j) + fx1(i)-fx1(i+1) +C +C *************************************** +C +1310 continue + return + end +C + subroutine fxppm(IMR,IML,UT,P,DC,flux,IORD) + parameter ( R3 = 1./3., R23 = 2./3. ) + DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1) + DIMENSION AR(0:IMR),AL(0:IMR),A6(0:IMR) + integer LMT +c logical first +c data first /.true./ +c SAVE LMT +c if(first) then +C +C correction calcul de LMT a chaque passage pour pouvoir choisir +c plusieurs schemas PPM pour differents traceurs +c IF (IORD.LE.0) then +c if(IMR.GE.144) then +c LMT = 0 +c elseif(IMR.GE.72) then +c LMT = 1 +c else +c LMT = 2 +c endif +c else +c LMT = IORD - 3 +c endif +C + LMT = IORD - 3 +c write(6,*) 'PPM option in E-W direction = ', LMT +c first = .false. +C endif +C + DO 10 i=1,IMR +10 AL(i) = 0.5*(p(i-1)+p(i)) + (DC(i-1) - DC(i))*R3 +C + do 20 i=1,IMR-1 +20 AR(i) = AL(i+1) + AR(IMR) = AL(1) +C + do 30 i=1,IMR +30 A6(i) = 3.*(p(i)+p(i) - (AL(i)+AR(i))) +C + if(LMT.LE.2) call lmtppm(DC(1),A6(1),AR(1),AL(1),P(1),IMR,LMT) +C + AL(0) = AL(IMR) + AR(0) = AR(IMR) + A6(0) = A6(IMR) +C + DO i=1,IMR + IF(UT(i).GT.0.) then + flux(i) = AR(i-1) + 0.5*UT(i)*(AL(i-1) - AR(i-1) + + & A6(i-1)*(1.-R23*UT(i)) ) + else + flux(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) + + & A6(i)*(1.+R23*UT(i))) + endif + enddo + return + end +C + subroutine xmist(IMR,IML,P,DC) + parameter( R24 = 1./24.) + dimension P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML) +C + do 10 i=1,IMR + tmp = R24*(8.*(p(i+1) - p(i-1)) + p(i-2) - p(i+2)) + Pmax = max(P(i-1), p(i), p(i+1)) - p(i) + Pmin = p(i) - min(P(i-1), p(i), p(i+1)) +10 DC(i) = sign(min(abs(tmp),Pmax,Pmin), tmp) + return + end +C + subroutine ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2 + & ,ymass,fx,A6,AR,AL,JORD) + dimension P(IMR,JNP),VC(IMR,JNP),ymass(IMR,JNP) + & ,DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP) +C Work array + DIMENSION fx(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) +C + JMR = JNP - 1 + len = IMR*(J2-J1+2) +C + if(JORD.eq.1) then + DO 1000 i=1,len + JT = REAL(J1) - VC(i,J1) +1000 fx(i,j1) = p(i,JT) + else + + call ymist(IMR,JNP,j1,P,DC2,4) +C + if(JORD.LE.0 .or. JORD.GE.3) then + + call fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD) + + else + DO 1200 i=1,len + JT = REAL(J1) - VC(i,J1) +1200 fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT) + endif + endif +C + DO 1300 i=1,len +1300 fx(i,j1) = fx(i,j1)*ymass(i,j1) +C + DO 1400 j=j1,j2 + DO 1400 i=1,IMR +1400 DQ(i,j) = DQ(i,j) + (fx(i,j) - fx(i,j+1)) * acosp(j) +C +C Poles + sum1 = fx(IMR,j1 ) + sum2 = fx(IMR,J2+1) + do i=1,IMR-1 + sum1 = sum1 + fx(i,j1 ) + sum2 = sum2 + fx(i,J2+1) + enddo +C + sum1 = DQ(1, 1) - sum1 * RCAP + sum2 = DQ(1,JNP) + sum2 * RCAP + do i=1,IMR + DQ(i, 1) = sum1 + DQ(i,JNP) = sum2 + enddo +C + if(j1.ne.2) then + do i=1,IMR + DQ(i, 2) = sum1 + DQ(i,JMR) = sum2 + enddo + endif +C + return + end +C + subroutine ymist(IMR,JNP,j1,P,DC,ID) + parameter ( R24 = 1./24. ) + dimension P(IMR,JNP),DC(IMR,JNP) +C + IMH = IMR / 2 + JMR = JNP - 1 + IJM3 = IMR*(JMR-3) +C + IF(ID.EQ.2) THEN + do 10 i=1,IMR*(JMR-1) + tmp = 0.25*(p(i,3) - p(i,1)) + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +10 CONTINUE + ELSE + do 12 i=1,IMH +C J=2 + tmp = (8.*(p(i,3) - p(i,1)) + p(i+IMH,2) - p(i,4))*R24 + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +C J=JMR + tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i+IMH,JMR))*R24 + Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR) + Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP)) + DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp) +12 CONTINUE + do 14 i=IMH+1,IMR +C J=2 + tmp = (8.*(p(i,3) - p(i,1)) + p(i-IMH,2) - p(i,4))*R24 + Pmax = max(p(i,1),p(i,2),p(i,3)) - p(i,2) + Pmin = p(i,2) - min(p(i,1),p(i,2),p(i,3)) + DC(i,2) = sign(min(abs(tmp),Pmin,Pmax),tmp) +C J=JMR + tmp=(8.*(p(i,JNP)-p(i,JMR-1))+p(i,JMR-2)-p(i-IMH,JMR))*R24 + Pmax = max(p(i,JMR-1),p(i,JMR),p(i,JNP)) - p(i,JMR) + Pmin = p(i,JMR) - min(p(i,JMR-1),p(i,JMR),p(i,JNP)) + DC(i,JMR) = sign(min(abs(tmp),Pmin,Pmax),tmp) +14 CONTINUE +C + do 15 i=1,IJM3 + tmp = (8.*(p(i,4) - p(i,2)) + p(i,1) - p(i,5))*R24 + Pmax = max(p(i,2),p(i,3),p(i,4)) - p(i,3) + Pmin = p(i,3) - min(p(i,2),p(i,3),p(i,4)) + DC(i,3) = sign(min(abs(tmp),Pmin,Pmax),tmp) +15 CONTINUE + ENDIF +C + if(j1.ne.2) then + do i=1,IMR + DC(i,1) = 0. + DC(i,JNP) = 0. + enddo + else +C Determine slopes in polar caps for scalars! +C + do 13 i=1,IMH +C South + tmp = 0.25*(p(i,2) - p(i+imh,2)) + Pmax = max(p(i,2),p(i,1), p(i+imh,2)) - p(i,1) + Pmin = p(i,1) - min(p(i,2),p(i,1), p(i+imh,2)) + DC(i,1)=sign(min(abs(tmp),Pmax,Pmin),tmp) +C North. + tmp = 0.25*(p(i+imh,JMR) - p(i,JMR)) + Pmax = max(p(i+imh,JMR),p(i,jnp), p(i,JMR)) - p(i,JNP) + Pmin = p(i,JNP) - min(p(i+imh,JMR),p(i,jnp), p(i,JMR)) + DC(i,JNP) = sign(min(abs(tmp),Pmax,pmin),tmp) +13 continue +C + do 25 i=imh+1,IMR + DC(i, 1) = - DC(i-imh, 1) + DC(i,JNP) = - DC(i-imh,JNP) +25 continue + endif + return + end +C + subroutine fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD) + parameter ( R3 = 1./3., R23 = 2./3. ) + real VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*) +C Local work arrays. + real AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP) + integer LMT +c logical first +C data first /.true./ +C SAVE LMT +C + IMH = IMR / 2 + JMR = JNP - 1 + j11 = j1-1 + IMJM1 = IMR*(J2-J1+2) + len = IMR*(J2-J1+3) +C if(first) then +C IF(JORD.LE.0) then +C if(JMR.GE.90) then +C LMT = 0 +C elseif(JMR.GE.45) then +C LMT = 1 +C else +C LMT = 2 +C endif +C else +C LMT = JORD - 3 +C endif +C +C first = .false. +C endif +C +c modifs pour pouvoir choisir plusieurs schemas PPM + LMT = JORD - 3 +C + DO 10 i=1,IMR*JMR + AL(i,2) = 0.5*(p(i,1)+p(i,2)) + (DC(i,1) - DC(i,2))*R3 + AR(i,1) = AL(i,2) +10 CONTINUE +C +CPoles: +C + DO i=1,IMH + AL(i,1) = AL(i+IMH,2) + AL(i+IMH,1) = AL(i,2) +C + AR(i,JNP) = AR(i+IMH,JMR) + AR(i+IMH,JNP) = AR(i,JMR) + ENDDO + +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c Rajout pour LMDZ.3.3 +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + AR(IMR,1)=AL(1,1) + AR(IMR,JNP)=AL(1,JNP) +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + + do 30 i=1,len +30 A6(i,j11) = 3.*(p(i,j11)+p(i,j11) - (AL(i,j11)+AR(i,j11))) +C + if(LMT.le.2) call lmtppm(DC(1,j11),A6(1,j11),AR(1,j11) + & ,AL(1,j11),P(1,j11),len,LMT) +C + + DO 140 i=1,IMJM1 + IF(VC(i,j1).GT.0.) then + flux(i,j1) = AR(i,j11) + 0.5*VC(i,j1)*(AL(i,j11) - AR(i,j11) + + & A6(i,j11)*(1.-R23*VC(i,j1)) ) + else + flux(i,j1) = AL(i,j1) - 0.5*VC(i,j1)*(AR(i,j1) - AL(i,j1) + + & A6(i,j1)*(1.+R23*VC(i,j1))) + endif +140 continue + return + end +C + subroutine yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD) + REAL p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP) + REAL WK(IMR,-1:JNP+2) +C + JMR = JNP-1 + IMH = IMR/2 + do j=1,JNP + do i=1,IMR + wk(i,j) = p(i,j) + enddo + enddo +C Poles: + do i=1,IMH + wk(i, -1) = p(i+IMH,3) + wk(i+IMH,-1) = p(i,3) + wk(i, 0) = p(i+IMH,2) + wk(i+IMH,0) = p(i,2) + wk(i,JNP+1) = p(i+IMH,JMR) + wk(i+IMH,JNP+1) = p(i,JMR) + wk(i,JNP+2) = p(i+IMH,JNP-2) + wk(i+IMH,JNP+2) = p(i,JNP-2) + enddo +c write(*,*) 'toto 1' +C -------------------------------- + IF(IAD.eq.2) then + do j=j1-1,j2+1 + do i=1,IMR +c write(*,*) 'avt NINT','i=',i,'j=',j + JP = NINT(VA(i,j)) + rv = JP - VA(i,j) +c write(*,*) 'VA=',VA(i,j), 'JP1=',JP,'rv=',rv + JP = j - JP +c write(*,*) 'JP2=',JP + a1 = 0.5*(wk(i,jp+1)+wk(i,jp-1)) - wk(i,jp) + b1 = 0.5*(wk(i,jp+1)-wk(i,jp-1)) +c write(*,*) 'a1=',a1,'b1=',b1 + ady(i,j) = wk(i,jp) + rv*(a1*rv + b1) - wk(i,j) + enddo + enddo +c write(*,*) 'toto 2' +C + ELSEIF(IAD.eq.1) then + do j=j1-1,j2+1 + do i=1,imr + JP = REAL(j)-VA(i,j) + ady(i,j) = VA(i,j)*(wk(i,jp)-wk(i,jp+1)) + enddo + enddo + ENDIF +C + if(j1.ne.2) then + sum1 = 0. + sum2 = 0. + do i=1,imr + sum1 = sum1 + ady(i,2) + sum2 = sum2 + ady(i,JMR) + enddo + sum1 = sum1 / IMR + sum2 = sum2 / IMR +C + do i=1,imr + ady(i, 2) = sum1 + ady(i,JMR) = sum2 + ady(i, 1) = sum1 + ady(i,JNP) = sum2 + enddo + else +C Poles: + sum1 = 0. + sum2 = 0. + do i=1,imr + sum1 = sum1 + ady(i,1) + sum2 = sum2 + ady(i,JNP) + enddo + sum1 = sum1 / IMR + sum2 = sum2 / IMR +C + do i=1,imr + ady(i, 1) = sum1 + ady(i,JNP) = sum2 + enddo + endif +C + return + end +C + subroutine xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx,IAD) + REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP) +C + JMR = JNP-1 + do 1309 j=j1,j2 + if(J.GT.JS .and. J.LT.JN) GO TO 1309 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + do i=-IML,0 + qtmp(i) = p(IMR+i,j) + qtmp(IMR+1-i) = p(1-i,j) + enddo +C + IF(IAD.eq.2) THEN + DO i=1,IMR + IP = NINT(UA(i,j)) + ru = IP - UA(i,j) + IP = i - IP + a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip) + b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1)) + adx(i,j) = qtmp(ip) + ru*(a1*ru + b1) + enddo + ELSEIF(IAD.eq.1) then + DO i=1,IMR + iu = UA(i,j) + ru = UA(i,j) - iu + iiu = i-iu + if(UA(i,j).GE.0.) then + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu-1)-qtmp(iiu)) + else + adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1)) + endif + enddo + ENDIF +C + do i=1,IMR + adx(i,j) = adx(i,j) - p(i,j) + enddo +1309 continue +C +C Eulerian upwind +C + do j=JS+1,JN-1 +C + do i=1,IMR + qtmp(i) = p(i,j) + enddo +C + qtmp(0) = p(IMR,J) + qtmp(IMR+1) = p(1,J) +C + IF(IAD.eq.2) THEN + qtmp(-1) = p(IMR-1,J) + qtmp(IMR+2) = p(2,J) + do i=1,imr + IP = NINT(UA(i,j)) + ru = IP - UA(i,j) + IP = i - IP + a1 = 0.5*(qtmp(ip+1)+qtmp(ip-1)) - qtmp(ip) + b1 = 0.5*(qtmp(ip+1)-qtmp(ip-1)) + adx(i,j) = qtmp(ip)- p(i,j) + ru*(a1*ru + b1) + enddo + ELSEIF(IAD.eq.1) then +C 1st order + DO i=1,IMR + IP = i - UA(i,j) + adx(i,j) = UA(i,j)*(qtmp(ip)-qtmp(ip+1)) + enddo + ENDIF + enddo +C + if(j1.ne.2) then + do i=1,IMR + adx(i, 2) = 0. + adx(i,JMR) = 0. + enddo + endif +C set cross term due to x-adv at the poles to zero. + do i=1,IMR + adx(i, 1) = 0. + adx(i,JNP) = 0. + enddo + return + end +C + subroutine lmtppm(DC,A6,AR,AL,P,IM,LMT) +C +C A6 = CURVATURE OF THE TEST PARABOLA +C AR = RIGHT EDGE VALUE OF THE TEST PARABOLA +C AL = LEFT EDGE VALUE OF THE TEST PARABOLA +C DC = 0.5 * MISMATCH +C P = CELL-AVERAGED VALUE +C IM = VECTOR LENGTH +C +C OPTIONS: +C +C LMT = 0: FULL MONOTONICITY +C LMT = 1: SEMI-MONOTONIC CONSTRAINT (NO UNDERSHOOTS) +C LMT = 2: POSITIVE-DEFINITE CONSTRAINT +C + parameter ( R12 = 1./12. ) + dimension A6(IM),AR(IM),AL(IM),P(IM),DC(IM) +C + if(LMT.eq.0) then +C Full constraint + do 100 i=1,IM + if(DC(i).eq.0.) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + else + da1 = AR(i) - AL(i) + da2 = da1**2 + A6DA = A6(i)*da1 + if(A6DA .lt. -da2) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + elseif(A6DA .gt. da2) then + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif + endif +100 continue + elseif(LMT.eq.1) then +C Semi-monotonic constraint + do 150 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 150 + if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +150 continue + elseif(LMT.eq.2) then + do 250 i=1,IM + if(abs(AR(i)-AL(i)) .GE. -A6(i)) go to 250 + fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12 + if(fmin.ge.0.) go to 250 + if(p(i).lt.AR(i) .and. p(i).lt.AL(i)) then + AR(i) = p(i) + AL(i) = p(i) + A6(i) = 0. + elseif(AR(i) .gt. AL(i)) then + A6(i) = 3.*(AL(i)-p(i)) + AR(i) = AL(i) - A6(i) + else + A6(i) = 3.*(AR(i)-p(i)) + AL(i) = AR(i) - A6(i) + endif +250 continue + endif + return + end +C + subroutine A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5) + dimension U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*) +C + do 35 j=j1,j2 + do 35 i=2,IMR +35 CRX(i,J) = dtdx5(j)*(U(i,j)+U(i-1,j)) +C + do 45 j=j1,j2 +45 CRX(1,J) = dtdx5(j)*(U(1,j)+U(IMR,j)) +C + do 55 i=1,IMR*JMR +55 CRY(i,2) = DTDY5*(V(i,2)+V(i,1)) + return + end +C + subroutine cosa(cosp,cose,JNP,PI,DP) + dimension cosp(*),cose(*) + JMR = JNP-1 + do 55 j=2,JNP + ph5 = -0.5*PI + (REAL(J-1)-0.5)*DP +55 cose(j) = cos(ph5) +C + JEQ = (JNP+1) / 2 + if(JMR .eq. 2*(JMR/2) ) then + do j=JNP, JEQ+1, -1 + cose(j) = cose(JNP+2-j) + enddo + else +C cell edge at equator. + cose(JEQ+1) = 1. + do j=JNP, JEQ+2, -1 + cose(j) = cose(JNP+2-j) + enddo + endif +C + do 66 j=2,JMR +66 cosp(j) = 0.5*(cose(j)+cose(j+1)) + cosp(1) = 0. + cosp(JNP) = 0. + return + end +C + subroutine cosc(cosp,cose,JNP,PI,DP) + dimension cosp(*),cose(*) +C + phi = -0.5*PI + do 55 j=2,JNP-1 + phi = phi + DP +55 cosp(j) = cos(phi) + cosp( 1) = 0. + cosp(JNP) = 0. +C + do 66 j=2,JNP + cose(j) = 0.5*(cosp(j)+cosp(j-1)) +66 CONTINUE +C + do 77 j=2,JNP-1 + cosp(j) = 0.5*(cose(j)+cose(j+1)) +77 CONTINUE + return + end +C + SUBROUTINE qckxyz (Q,qtmp,IMR,JNP,NLAY,j1,j2,cosp,acosp, + & cross,IC,NSTEP) +C + parameter( tiny = 1.E-60 ) + DIMENSION Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*) + logical cross +C + NLAYM1 = NLAY-1 + len = IMR*(j2-j1+1) + ip = 0 +C +C Top layer + L = 1 + icr = 1 + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 50 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) goto 50 +C + if(cross) then + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + endif + if(icr.eq.0) goto 50 +C +C Vertical filling... + do i=1,len + IF( Q(i,j1,1).LT.0.) THEN + ip = ip + 1 + Q(i,j1,2) = Q(i,j1,2) + Q(i,j1,1) + Q(i,j1,1) = 0. + endif + enddo +C +50 continue + DO 225 L = 2,NLAYM1 + icr = 1 +C + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 225 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) go to 225 + if(cross) then + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + endif + if(icr.eq.0) goto 225 +C + do i=1,len + IF( Q(I,j1,L).LT.0.) THEN +C + ip = ip + 1 +C From above + qup = Q(I,j1,L-1) + qly = -Q(I,j1,L) + dup = min(qly,qup) + Q(I,j1,L-1) = qup - dup + Q(I,j1,L ) = dup-qly +C Below + Q(I,j1,L+1) = Q(I,j1,L+1) + Q(I,j1,L) + Q(I,j1,L) = 0. + ENDIF + ENDDO +225 CONTINUE +C +C BOTTOM LAYER + sum = 0. + L = NLAY +C + call filns(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + if(ipy.eq.0) goto 911 + call filew(q(1,1,L),qtmp,IMR,JNP,j1,j2,ipx,tiny) + if(ipx.eq.0) goto 911 +C + call filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + if(icr.eq.0) goto 911 +C + DO I=1,len + IF( Q(I,j1,L).LT.0.) THEN + ip = ip + 1 +c +C From above +C + qup = Q(I,j1,NLAYM1) + qly = -Q(I,j1,L) + dup = min(qly,qup) + Q(I,j1,NLAYM1) = qup - dup +C From "below" the surface. + sum = sum + qly-dup + Q(I,j1,L) = 0. + ENDIF + ENDDO +C +911 continue +C + if(ip.gt.IMR) then + write(6,*) 'IC=',IC,' STEP=',NSTEP, + & ' Vertical filling pts=',ip + endif +C + if(sum.gt.1.e-25) then + write(6,*) IC,NSTEP,' Mass source from the ground=',sum + endif + RETURN + END +C + subroutine filcr(q,IMR,JNP,j1,j2,cosp,acosp,icr,tiny) + dimension q(IMR,*),cosp(*),acosp(*) + icr = 0 + do 65 j=j1+1,j2-1 + DO 50 i=1,IMR-1 + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-E + dn = q(i+1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i+1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-E + ds = q(i+1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i+1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +50 continue + if(icr.eq.0 .and. q(IMR,j).ge.0.) goto 65 + DO 55 i=2,IMR + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-W + dn = q(i-1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i-1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-W + ds = q(i-1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i-1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +55 continue +C ***************************************** +C i=1 + i=1 + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-W + dn = q(IMR,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(IMR,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-W + ds = q(IMR,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(IMR,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +C ***************************************** +C i=IMR + i=IMR + IF(q(i,j).LT.0.) THEN + icr = 1 + dq = - q(i,j)*cosp(j) +C N-E + dn = q(1,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(1,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C S-E + ds = q(1,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(1,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +C ***************************************** +65 continue +C + do i=1,IMR + if(q(i,j1).lt.0. .or. q(i,j2).lt.0.) then + icr = 1 + goto 80 + endif + enddo +C +80 continue +C + if(q(1,1).lt.0. .or. q(1,jnp).lt.0.) then + icr = 1 + endif +C + return + end +C + subroutine filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny) + dimension q(IMR,*),cosp(*),acosp(*) +c logical first +c data first /.true./ +c save cap1 +C +c if(first) then + DP = 4.*ATAN(1.)/REAL(JNP-1) + CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP +c first = .false. +c endif +C + ipy = 0 + do 55 j=j1+1,j2-1 + DO 55 i=1,IMR + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C North + dn = q(i,j+1)*cosp(j+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j+1) = (dn - d1)*acosp(j+1) + dq = dq - d1 +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif +55 continue +C + do i=1,imr + IF(q(i,j1).LT.0.) THEN + ipy = 1 + dq = - q(i,j1)*cosp(j1) +C North + dn = q(i,j1+1)*cosp(j1+1) + d0 = max(0.,dn) + d1 = min(dq,d0) + q(i,j1+1) = (dn - d1)*acosp(j1+1) + q(i,j1) = (d1 - dq)*acosp(j1) + tiny + endif + enddo +C + j = j2 + do i=1,imr + IF(q(i,j).LT.0.) THEN + ipy = 1 + dq = - q(i,j)*cosp(j) +C South + ds = q(i,j-1)*cosp(j-1) + d0 = max(0.,ds) + d2 = min(dq,d0) + q(i,j-1) = (ds - d2)*acosp(j-1) + q(i,j) = (d2 - dq)*acosp(j) + tiny + endif + enddo +C +C Check Poles. + if(q(1,1).lt.0.) then + dq = q(1,1)*cap1/REAL(IMR)*acosp(j1) + do i=1,imr + q(i,1) = 0. + q(i,j1) = q(i,j1) + dq + if(q(i,j1).lt.0.) ipy = 1 + enddo + endif +C + if(q(1,JNP).lt.0.) then + dq = q(1,JNP)*cap1/REAL(IMR)*acosp(j2) + do i=1,imr + q(i,JNP) = 0. + q(i,j2) = q(i,j2) + dq + if(q(i,j2).lt.0.) ipy = 1 + enddo + endif +C + return + end +C + subroutine filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny) + dimension q(IMR,*),qtmp(JNP,IMR) +C + ipx = 0 +C Copy & swap direction for vectorization. + do 25 i=1,imr + do 25 j=j1,j2 +25 qtmp(j,i) = q(i,j) +C + do 55 i=2,imr-1 + do 55 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,i-1)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,i-1) = qtmp(j,i-1) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,i+1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,i+1) = qtmp(j,i+1) - d2 + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +55 continue +c + i=1 + do 65 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,imr)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,imr) = qtmp(j,imr) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,i+1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,i+1) = qtmp(j,i+1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +65 continue + i=IMR + do 75 j=j1,j2 + if(qtmp(j,i).lt.0.) then + ipx = 1 +c west + d0 = max(0.,qtmp(j,i-1)) + d1 = min(-qtmp(j,i),d0) + qtmp(j,i-1) = qtmp(j,i-1) - d1 + qtmp(j,i) = qtmp(j,i) + d1 +c east + d0 = max(0.,qtmp(j,1)) + d2 = min(-qtmp(j,i),d0) + qtmp(j,1) = qtmp(j,1) - d2 +c + qtmp(j,i) = qtmp(j,i) + d2 + tiny + endif +75 continue +C + if(ipx.ne.0) then + do 85 j=j1,j2 + do 85 i=1,imr +85 q(i,j) = qtmp(j,i) + else +C +C Poles. + if(q(1,1).lt.0. or. q(1,JNP).lt.0.) ipx = 1 + endif + return + end +C + subroutine zflip(q,im,km,nc) +C This routine flip the array q (in the vertical). + real q(im,km,nc) +C local dynamic array + real qtmp(im,km) +C + do 4000 IC = 1, nc +C + do 1000 k=1,km + do 1000 i=1,im + qtmp(i,k) = q(i,km+1-k,IC) +1000 continue +C + do 2000 i=1,im*km +2000 q(i,1,IC) = qtmp(i,1) +4000 continue + return + end Index: LMDZ5/trunk/libf/dyn3d_common/prather.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/prather.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/prather.F (revision 1952) @@ -0,0 +1,361 @@ +! +! $Header$ +! + SUBROUTINE prather (q,w,masse,pbaru,pbarv,nt,dt) + IMPLICIT NONE + +c======================================================================= +c Adaptation LMDZ: A.Armengaud (LGGE) +c ---------------- +c +c ************************************************ +c Transport des traceurs par la methode de prather +c Ref : +c +c ************************************************ +c q,w,pext,pbaru et pbarv : arguments d'entree pour le s-pg +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments: +c ---------- + INTEGER iq,nt + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL masse(iip1,jjp1,llm) + REAL q( iip1,jjp1,llm,0:9) + REAL w( ip1jmp1,llm ) + integer ordre,ilim + +c Local: +c ------ + LOGICAL limit + real zq(iip1,jjp1,llm) + REAL sm ( iip1,jjp1, llm ) + REAL s0( iip1,jjp1,llm ), sx( iip1,jjp1,llm ) + REAL sy( iip1,jjp1,llm ), sz( iip1,jjp1,llm ) + REAL sxx( iip1,jjp1,llm) + REAL sxy( iip1,jjp1,llm) + REAL sxz( iip1,jjp1,llm) + REAL syy( iip1,jjp1,llm ) + REAL syz( iip1,jjp1,llm ) + REAL szz( iip1,jjp1,llm ),zz + INTEGER i,j,l,indice + real sxn(iip1),sxs(iip1) + + real sinlon(iip1),sinlondlon(iip1) + real coslon(iip1),coslondlon(iip1) + real qmin,qmax + save qmin,qmax + save sinlon,coslon,sinlondlon,coslondlon + real dyn1,dyn2,dys1,dys2,qpn,qps,dqzpn,dqzps + real masn,mass +c + REAL SSUM + integer ismax,ismin + EXTERNAL SSUM, ismin,ismax + logical first + save first + EXTERNAL advxp,advyp,advzp + + + data first/.true./ + data qmin,qmax/-1.e33,1.e33/ + + +c========================================================================== +c========================================================================== +c MODIFICATION POUR PAS DE TEMPS ADAPTATIF, dtvr remplace par dt +c========================================================================== +c========================================================================== + REAL dt +c========================================================================== + limit = .TRUE. + + if(first) then + print*,'SCHEMA PRATHER' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + enddo + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q( i,j,l,1 )=0. + q( i,j,l,2)=0. + q( i,j,l,3)=0. + q( i,j,l,4)=0. + q( i,j,l,5)=0. + q( i,j,l,6)=0. + q( i,j,l,7)=0. + q( i,j,l,8)=0. + q( i,j,l,9)=0. + ENDDO + ENDDO + ENDDO + endif +c Fin modif Fred + +c *** On calcule la masse d'air en kg + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + sm( i,j,llm+1-l ) =masse(i,j,l) + ENDDO + ENDDO + ENDDO + +c *** q contient les qqtes de traceur avant l'advection + +c *** Affectation des tableaux S a partir de Q + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + s0( i,j,l) = q ( i,j,llm+1-l,0 )*sm(i,j,l) + sx( i,j,l) = q( i,j,llm+1-l,1 )*sm(i,j,l) + sy( i,j,l) = q( i,j,llm+1-l,2)*sm(i,j,l) + sz( i,j,l) = q( i,j,llm+1-l,3)*sm(i,j,l) + sxx( i,j,l) = q( i,j,llm+1-l,4)*sm(i,j,l) + sxy( i,j,l) = q( i,j,llm+1-l,5)*sm(i,j,l) + sxz( i,j,l) = q( i,j,llm+1-l,6)*sm(i,j,l) + syy( i,j,l) = q( i,j,llm+1-l,7)*sm(i,j,l) + syz( i,j,l) = q( i,j,llm+1-l,8)*sm(i,j,l) + szz( i,j,l) = q( i,j,llm+1-l,9)*sm(i,j,l) + ENDDO + ENDDO + ENDDO +c *** Appel des subroutines d'advection en X, en Y et en Z +c *** Advection avec "time-splitting" + +c----------------------------------------------------------- + do indice =1,nt + call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + end do + do l=1,llm + do i=1,iip1 + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo +c--------------------------------------------------------- + call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) +c--------------------------------------------------------- + +c--------------------------------------------------------- + do j=1,jjp1 + do i=1,iip1 + sz(i,j,1)=0. + sz(i,j,llm)=0. + sxz(i,j,1)=0. + sxz(i,j,llm)=0. + syz(i,j,1)=0. + syz(i,j,llm)=0. + szz(i,j,1)=0. + szz(i,j,llm)=0. + enddo + enddo + call advzp( limit,dt*nt,w,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + do l=1,llm + do i=1,iip1 + sy(i,1,l)=0. + sy(i,jjp1,l)=0. + enddo + enddo + +c--------------------------------------------------------- + +c--------------------------------------------------------- + call advyp( limit,.5*dt*nt,pbarv,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) +c--------------------------------------------------------- + DO l = 1,llm + DO j = 1,jjp1 + s0( iip1,j,l)=s0( 1,j,l ) + sx( iip1,j,l)=sx( 1,j,l ) + sy( iip1,j,l)=sy( 1,j,l ) + sz( iip1,j,l)=sz( 1,j,l ) + sxx( iip1,j,l)=sxx( 1,j,l ) + sxy( iip1,j,l)=sxy( 1,j,l) + sxz( iip1,j,l)=sxz( 1,j,l ) + syy( iip1,j,l)=syy( 1,j,l ) + syz( iip1,j,l)=syz( 1,j,l) + szz( iip1,j,l)=szz( 1,j,l ) + ENDDO + ENDDO + do indice=1,nt + call advxp( limit,0.5*dt,pbaru,sm,s0,sx,sy,sz + . ,sxx,sxy,sxz,syy,syz,szz,1 ) + end do +c--------------------------------------------------------- +c--------------------------------------------------------- +c *** On repasse les S dans la variable qpr +c *** On repasse les S dans la variable q directement 14/10/94 + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iip1 + q( i,j,llm+1-l,0 )=s0( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,1 ) = sx( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,2 ) = sy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,3 ) = sz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,4 ) = sxx( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,5 ) = sxy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,6 ) = sxz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,7 ) = syy( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,8 ) = syz( i,j,l )/sm(i,j,l) + q( i,j,llm+1-l,9 ) = szz( i,j,l )/sm(i,j,l) + ENDDO + ENDDO + ENDDO + +c--------------------------------------------------------- +c go to 777 +c filtrages aux poles + +c Traitements specifiques au pole + +c filtrages aux poles + DO l=1,llm +c filtrages aux poles + masn=ssum(iim,sm(1,1,l),1) + mass=ssum(iim,sm(1,jjp1,l),1) + qpn=ssum(iim,s0(1,1,l),1)/masn + qps=ssum(iim,s0(1,jjp1,l),1)/mass + dqzpn=ssum(iim,sz(1,1,l),1)/masn + dqzps=ssum(iim,sz(1,jjp1,l),1)/mass + do i=1,iip1 + q( i,1,llm+1-l,3)=dqzpn + q( i,jjp1,llm+1-l,3)=dqzps + q( i,1,llm+1-l,0)=qpn + q( i,jjp1,llm+1-l,0)=qps + enddo +c enddo +c print*,'qpn',qpn,'qps',qps +c print*,'dqzpn',dqzpn,'dqzps',dqzps +c enddo + dyn1=0. + dys1=0. + dyn2=0. + dys2=0. + do i=1,iim + zz=s0(i,2,l)/sm(i,2,l)-q(i,1,llm+1-l,0) + dyn1=dyn1+sinlondlon(i)*zz + dyn2=dyn2+coslondlon(i)*zz + zz=q(i,jjp1,llm+1-l,0)-s0(i,jjm,l)/sm(i,jjm,l) + dys1=dys1+sinlondlon(i)*zz + dys2=dys2+coslondlon(i)*zz + enddo + do i=1,iim + q(i,1,llm+1-l,2)= + $ (sinlon(i)*dyn1+coslon(i)*dyn2)/2. + q(i,1,llm+1-l,0)=q(i,1,llm+1-l,0) + $ +q(i,1,llm+1-l,2) + q(i,jjp1,llm+1-l,2)= + $ (sinlon(i)*dys1+coslon(i)*dys2)/2. + q(i,jjp1,llm+1-l,0)=q(i,jjp1,llm+1-l,0) + $ -q(i,jjp1,llm+1-l,2) + enddo + q(iip1,1,llm+1-l,0)=q(1,1,llm+1-l,0) + q(iip1,jjp1,llm+1-l,0)=q(1,jjp1,llm+1-l,0) + do i=1,iim + sxn(i)=q(i+1,1,llm+1-l,0)-q(i,1,llm+1-l,0) + sxs(i)=q(i+1,jjp1,llm+1-l,0)-q(i,jjp1,llm+1-l,0) + enddo + sxn(iip1)=sxn(1) + sxs(iip1)=sxs(1) + do i=1,iim + q(i+1,1,llm+1-l,1)=0.25*(sxn(i)+sxn(i+1)) + q(i+1,jjp1,llm+1-l,1)=0.25*(sxs(i)+sxs(i+1)) + END DO + q(1,1,llm+1-l,1)=q(iip1,1,llm+1-l,1) + q(1,jjp1,llm+1-l,1)= + $ q(iip1,jjp1,llm+1-l,1) + enddo + do l=1,llm + do i=1,iim + q( i,1,llm+1-l,4)=0. + q( i,jjp1,llm+1-l,4)=0. + q( i,1,llm+1-l,5)=0. + q( i,jjp1,llm+1-l,5)=0. + q( i,1,llm+1-l,6)=0. + q( i,jjp1,llm+1-l,6)=0. + q( i,1,llm+1-l,7)=0. + q( i,jjp1,llm+1-l,7)=0. + q( i,1,llm+1-l,8)=0. + q( i,jjp1,llm+1-l,8)=0. + q( i,1,llm+1-l,9)=0. + q( i,jjp1,llm+1-l,9)=0. + enddo + ENDDO + +777 continue +c +c bouclage en longitude + do l=1,llm + do j=1,jjp1 + q(iip1,j,l,0)=q(1,j,l,0) + q(iip1,j,llm+1-l,0)=q(1,j,llm+1-l,0) + q(iip1,j,llm+1-l,1)=q(1,j,llm+1-l,1) + q(iip1,j,llm+1-l,2)=q(1,j,llm+1-l,2) + q(iip1,j,llm+1-l,3)=q(1,j,llm+1-l,3) + q(iip1,j,llm+1-l,4)=q(1,j,llm+1-l,4) + q(iip1,j,llm+1-l,5)=q(1,j,llm+1-l,5) + q(iip1,j,llm+1-l,6)=q(1,j,llm+1-l,6) + q(iip1,j,llm+1-l,7)=q(1,j,llm+1-l,7) + q(iip1,j,llm+1-l,8)=q(1,j,llm+1-l,8) + q(iip1,j,llm+1-l,9)=q(1,j,llm+1-l,9) + enddo + enddo + DO l = 1,llm + DO j = 2,jjm + DO i = 1,iip1 + IF (q(i,j,l,0).lt.0.) THEN + PRINT*,'------------ BIP-----------' + PRINT*,'S0(',i,j,l,')=',q(i,j,l,0), + $ q(i,j-1,l,0) + PRINT*,'SX(',i,j,l,')=',q(i,j,l,1) + PRINT*,'SY(',i,j,l,')=',q(i,j,l,2), + $ q(i,j-1,l,2) + PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3) +c PRINT*,' PBL EN SORTIE D'' ADVZP' + q(i,j,l,0)=0. +c STOP + ENDIF + ENDDO + ENDDO + do j=1,jjp1,jjm + do i=1,iip1 + IF (q(i,j,l,0).lt.0.) THEN + PRINT*,'------------ BIP 2-----------' + PRINT*,'S0(',i,j,l,')=',q(i,j,l,0) + PRINT*,'SX(',i,j,l,')=',q(i,j,l,1) + PRINT*,'SY(',i,j,l,')=',q(i,j,l,2) + PRINT*,'SZ(',i,j,l,')=',q(i,j,l,3) + + q(i,j,l,0)=0. +c STOP + ENDIF + enddo + enddo + ENDDO + RETURN + END Index: LMDZ5/trunk/libf/dyn3d_common/sortvarc.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/sortvarc.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/sortvarc.F (revision 1952) @@ -0,0 +1,166 @@ +! +! $Id$ +! + SUBROUTINE sortvarc + $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time , + $ vcov ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c sortie des variables de controle +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "logic.h" +#include "temps.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL vcov(ip1jm,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL vorpot(ip1jm,llm) + REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm) + REAL dp(ip1jmp1) + REAL time + REAL pk(ip1jmp1,llm) + +c Local: +c ------ + + REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm) + REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1) + REAL cosphi(ip1jm),omegcosp(ip1jm) + REAL dtvrs1j,rjour,heure,radsg,radomeg + REAL rday, massebxy(ip1jm,llm) + INTEGER l, ij, imjmp1 + + REAL SSUM + +c----------------------------------------------------------------------- + + dtvrs1j = dtvr/daysec + rjour = REAL( INT( itau * dtvrs1j )) + heure = ( itau*dtvrs1j-rjour ) * 24. + imjmp1 = iim * jjp1 + IF(ABS(heure - 24.).LE.0.0001 ) heure = 0. +c + CALL massbarxy ( masse, massebxy ) + +c ..... Calcul de rmsdpdt ..... + + ge(:)=dp(:)*dp(:) + + rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) +c + rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) + + CALL SCOPY( ijp1llm,bern,1,bernf,1 ) + CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1) + +c ..... Calcul du moment angulaire ..... + + radsg = rad /g + radomeg = rad * omeg +c + DO ij=iip2,ip1jm + cosphi( ij ) = COS(rlatu((ij-1)/iip1+1)) + omegcosp(ij) = radomeg * cosphi(ij) + ENDDO + +c ... Calcul de l'energie,de l'enstrophie,de l'entropie et de rmsv . + + DO l=1,llm + DO ij = 1,ip1jm + vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l) + ENDDO + ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1)) + + DO ij = 1,ip1jmp1 + ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l) + + s bernf(ij,l)-phi(ij,l)) + ENDDO + etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij = 1, ip1jmp1 + ge(ij) = masse(ij,l)*teta(ij,l) + ENDDO + stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij=1,ip1jmp1 + ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.) + ENDDO + rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)) + + DO ij =iip2,ip1jm + ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) * + * cosphi(ij) + ENDDO + angl(l) = radsg * + s (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1)) + ENDDO + + DO ij=1,ip1jmp1 + ge(ij)= ps(ij)*aire(ij) + ENDDO + ptot = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1) + etot = SSUM( llm, etotl, 1 ) + ztot = SSUM( llm, ztotl, 1 ) + stot = SSUM( llm, stotl, 1 ) + rmsv = SSUM( llm, rmsvl, 1 ) + ang = SSUM( llm, angl, 1 ) + +c rday = REAL(INT ( day_ini + time )) +c + rday = REAL(INT(time-jD_ref-jH_ref)) + IF(ptot0.eq.0.) THEN + PRINT 3500, itau, rday, heure,time + PRINT*,'WARNING!!! On recalcule les valeurs initiales de :' + PRINT*,'ptot,rmsdpdt,etot,ztot,stot,rmsv,ang' + PRINT *, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang + etot0 = etot + ptot0 = ptot + ztot0 = ztot + stot0 = stot + ang0 = ang + END IF + + etot= etot/etot0 + rmsv= SQRT(rmsv/ptot) + ptot= ptot/ptot0 + ztot= ztot/ztot0 + stot= stot/stot0 + ang = ang /ang0 + + + PRINT 3500, itau, rday, heure, time + PRINT 4000, ptot,rmsdpdt,etot,ztot,stot,rmsv,ang + + RETURN + +3500 FORMAT(10("*"),4x,'pas',i7,5x,'jour',f9.0,'heure',f5.1,4x + * ,'date',f14.4,4x,10("*")) +4000 FORMAT(10x,'masse',4x,'rmsdpdt',7x,'energie',2x,'enstrophie' + * ,2x,'entropie',3x,'rmsv',4x,'mt.ang',/,'GLOB ' + . ,f10.6,e13.6,5f10.3/ + * ) + END + Index: LMDZ5/trunk/libf/dyn3d_common/sortvarc0.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/sortvarc0.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/sortvarc0.F (revision 1952) @@ -0,0 +1,141 @@ +! +! $Id$ +! + SUBROUTINE sortvarc0 + $(itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time , + $ vcov) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c sortie des variables de controle +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "logic.h" +#include "temps.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL ucov(ip1jmp1,llm),teta(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL vcov(ip1jm,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL vorpot(ip1jm,llm) + REAL phi(ip1jmp1,llm),bern(ip1jmp1,llm) + REAL dp(ip1jmp1) + REAL time + REAL pk(ip1jmp1,llm) + +c Local: +c ------ + + REAL vor(ip1jm),bernf(ip1jmp1,llm),ztotl(llm) + REAL etotl(llm),stotl(llm),rmsvl(llm),angl(llm),ge(ip1jmp1) + REAL cosphi(ip1jm),omegcosp(ip1jm) + REAL dtvrs1j,rjour,heure,radsg,radomeg + REAL rday, massebxy(ip1jm,llm) + INTEGER l, ij, imjmp1 + + REAL SSUM + integer ismin,ismax + +c----------------------------------------------------------------------- + + dtvrs1j = dtvr/daysec + rjour = REAL( INT( itau * dtvrs1j )) + heure = ( itau*dtvrs1j-rjour ) * 24. + imjmp1 = iim * jjp1 + IF(ABS(heure - 24.).LE.0.0001 ) heure = 0. +c + CALL massbarxy ( masse, massebxy ) + +c ..... Calcul de rmsdpdt ..... + + ge=dp*dp + + rmsdpdt = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) +c + rmsdpdt = daysec* 1.e-2 * SQRT(rmsdpdt/imjmp1) + + CALL SCOPY( ijp1llm,bern,1,bernf,1 ) + CALL filtreg(bernf,jjp1,llm,-2,2,.TRUE.,1) + +c ..... Calcul du moment angulaire ..... + + radsg = rad /g + radomeg = rad * omeg +c + DO ij=iip2,ip1jm + cosphi( ij ) = COS(rlatu((ij-1)/iip1+1)) + omegcosp(ij) = radomeg * cosphi(ij) + ENDDO + +c ... Calcul de l'energie,de l'enstrophie,de l'entropie et de rmsv . + + DO l=1,llm + DO ij = 1,ip1jm + vor(ij)=vorpot(ij,l)*vorpot(ij,l)*massebxy(ij,l) + ENDDO + ztotl(l)=(SSUM(ip1jm,vor,1)-SSUM(jjm,vor,iip1)) + + DO ij = 1,ip1jmp1 + ge(ij)= masse(ij,l)*(phis(ij)+teta(ij,l)*pk(ij,l) + + s bernf(ij,l)-phi(ij,l)) + ENDDO + etotl(l) = SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij = 1, ip1jmp1 + ge(ij) = masse(ij,l)*teta(ij,l) + ENDDO + stotl(l)= SSUM(ip1jmp1,ge,1) - SSUM(jjp1,ge,iip1) + + DO ij=1,ip1jmp1 + ge(ij)=masse(ij,l)*AMAX1(bernf(ij,l)-phi(ij,l),0.) + ENDDO + rmsvl(l)=2.*(SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1)) + + DO ij =iip2,ip1jm + ge(ij)=(ucov(ij,l)/cu(ij)+omegcosp(ij))*masse(ij,l) * + * cosphi(ij) + ENDDO + angl(l) = radsg * + s (SSUM(ip1jm-iip1,ge(iip2),1)-SSUM(jjm-1,ge(iip2),iip1)) + ENDDO + + DO ij=1,ip1jmp1 + ge(ij)= ps(ij)*aire(ij) + ENDDO + ptot0 = SSUM(ip1jmp1,ge,1)-SSUM(jjp1,ge,iip1) + etot0 = SSUM( llm, etotl, 1 ) + ztot0 = SSUM( llm, ztotl, 1 ) + stot0 = SSUM( llm, stotl, 1 ) + rmsv = SSUM( llm, rmsvl, 1 ) + ang0 = SSUM( llm, angl, 1 ) + + rday = REAL(INT (time )) +c + PRINT 3500, itau, rday, heure, time + PRINT *, ptot0,etot0,ztot0,stot0,ang0 + +3500 FORMAT(10("*"),4x,'pas',i7,5x,'jour',f5.0,'heure',f5.1,4x + * ,'date',f10.5,4x,10("*")) + RETURN + END + Index: LMDZ5/trunk/libf/dyn3d_common/startvar.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/startvar.F90 (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/startvar.F90 (revision 1952) @@ -0,0 +1,783 @@ +! +! $Id$ +! +!******************************************************************************* +! +MODULE startvar +! +!******************************************************************************* +! +!------------------------------------------------------------------------------- +! Purpose: Access data from the database of atmospheric to initialize the model. +!------------------------------------------------------------------------------- +! Comments: +! +! * This module is designed to work for Earth (and with ioipsl) +! +! * There are three ways to acces data, depending on the type of field +! which needs to be extracted. In any case the call should come after a restget +! and should be of the type : CALL startget(...) +! +! - A 1D variable on the physical grid : +! CALL startget_phys1d((varname, iml, jml, lon_in, lat_in, nbindex, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! - A 2D variable on the dynamical grid : +! CALL startget_phys2d(varname, iml, jml, lon_in, lat_in, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! - A 3D variable on the dynamical grid : +! CALL startget_dyn((varname, iml, jml, lon_in, lat_in, lml, pls, workvar, & +! champ, val_exp, jml2, lon_in2, lat_in2, ibar ) +! +! * Data needs to be in NetCDF format +! +! * Variables should have the following names in the files: +! 'RELIEF' : High resolution orography +! 'ST' : Surface temperature +! 'CDSW' : Soil moisture +! 'Z' : Surface geopotential +! 'SP' : Surface pressure +! 'U' : East ward wind +! 'V' : Northward wind +! 'TEMP' : Temperature +! 'R' : Relative humidity +! +! * There is a big mess with the longitude size. Should it be iml or iml+1 ? +! I have chosen to use the iml+1 as an argument to this routine and we declare +! internaly smaller fields when needed. This needs to be cleared once and for +! all in LMDZ. A convention is required. +!------------------------------------------------------------------------------- +#ifdef CPP_EARTH + USE ioipsl + IMPLICIT NONE + + PRIVATE + PUBLIC startget_phys2d, startget_phys1d, startget_dyn +! INTERFACE startget +! MODULE PROCEDURE startget_phys1d, startget_phys2d, startget_dyn +! END INTERFACE + + REAL, SAVE :: deg2rad, pi + INTEGER, SAVE :: iml_rel, jml_rel + INTEGER, SAVE :: fid_phys, iml_phys, jml_phys + INTEGER, SAVE :: fid_dyn, iml_dyn, jml_dyn, llm_dyn, ttm_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lon_phys, lon_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lat_phys, lat_dyn + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lon_rug, lon_alb, lon_rel + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: lat_rug, lat_alb, lat_rel + REAL, DIMENSION(:), ALLOCATABLE, TARGET, SAVE :: levdyn_ini + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: relief, zstd, zsig, zgam + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: masque, zthe, zpic, zval + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: rugo, phis, tsol, qsol + REAL, DIMENSION(:,:), ALLOCATABLE, TARGET, SAVE :: psol_dyn + REAL, DIMENSION(:,:,:), ALLOCATABLE, TARGET, SAVE :: var_ana3d + + CONTAINS + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, lat_in, nbindex, champ, & + val_exp ,jml2, lon_in2, lat_in2, ibar) +! +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: nbindex + REAL, DIMENSION(nbindex), INTENT(INOUT) :: champ + REAL, INTENT(IN) :: val_exp + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(:,:), POINTER :: v2d +!------------------------------------------------------------------------------- + v2d=>NULL() + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + +!--- CHECKING IF THE FIELD IS KNOWN ; READING UNALLOCATED FILES + SELECT CASE(varname) + CASE('tsol') + IF(.NOT.ALLOCATED(tsol)) & + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('qsol') + IF(.NOT.ALLOCATED(qsol)) & + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('psol') + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn (iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('zmea','zstd','zsig','zgam','zthe','zpic','zval') + IF(.NOT.ALLOCATED(relief)) & + CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('rads','snow','tslab','seaice','rugmer','agsno') + CASE DEFAULT + WRITE(lunout,*)'startget_phys1d' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + +!--- SELECTING v2d FOR WANTED VARIABLE AND CHEKING ITS SIZE + SELECT CASE(varname) + CASE('rads','snow','tslab','seaice'); champ=0.0 + CASE('rugmer'); champ(:)=0.001 + CASE('agsno'); champ(:)=50.0 + CASE DEFAULT + SELECT CASE(varname) + CASE('tsol'); v2d=>tsol + CASE('qsol'); v2d=>qsol + CASE('psol'); v2d=>psol_dyn + CASE('zmea'); v2d=>relief + CASE('zstd'); v2d=>zstd + CASE('zsig'); v2d=>zsig + CASE('zgam'); v2d=>zgam + CASE('zthe'); v2d=>zthe + CASE('zpic'); v2d=>zpic + CASE('zval'); v2d=>zval + END SELECT + IF(SIZE(v2d)/=SIZE(lon_in)*SIZE(lat_in)) THEN + WRITE(lunout,*)'STARTVAR module has been initialized to the wrong size' + STOP + END IF + CALL gr_dyn_fi(1,iml,jml,nbindex,v2d,champ) + END SELECT + + ELSE + +!--- SOME FIELDS ARE CAUGHT: MAY BE NEEDED FOR A 3D INTEPROLATION + SELECT CASE(varname) + CASE('tsol') + IF(.NOT.ALLOCATED(tsol)) ALLOCATE(tsol(iml,jml)) + CALL gr_fi_dyn(1,iml,jml,nbindex,champ,tsol) + END SELECT + + END IF + +END SUBROUTINE startget_phys1d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in, champ, val_exp, & + jml2, lon_in2, lat_in2 , ibar, msk) +! +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + REAL, DIMENSION(iml,jml), INTENT(INOUT) :: champ + REAL, INTENT(IN) :: val_exp + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar + REAL, DIMENSION(iml,jml), INTENT(IN), OPTIONAL :: msk +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(:,:), POINTER :: v2d=>NULL() + LOGICAL :: lrelief1, lrelief2 +!------------------------------------------------------------------------------- + v2d=>NULL() + lrelief1=(.NOT.ALLOCATED(relief).AND. PRESENT(msk)) + lrelief2=(.NOT.ALLOCATED(relief).AND..NOT.PRESENT(msk)) + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + +!--- CHECKING IF THE FIELD IS KNOWN ; READING UNALLOCATED FILES + SELECT CASE(varname) + CASE('psol') + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn (iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + CASE('relief') + IF(lrelief1) CALL start_init_orog(iml,jml,lon_in,lat_in,msk) + IF(lrelief2) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('surfgeo') + IF(.NOT.ALLOCATED(phis)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE('rugosite','masque') + IF(.NOT.ALLOCATED(rugo)) CALL start_init_orog(iml,jml,lon_in,lat_in) + CASE DEFAULT + WRITE(lunout,*)'startget_phys2d' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + +!--- SELECTING v2d FOR WANTED VARIABLE AND CHEKING ITS SIZE + SELECT CASE(varname) + CASE('psol'); v2d=>psol_dyn + CASE('relief'); v2d=>relief + CASE('rugosite'); v2d=>rugo + CASE('masque'); v2d=>masque + CASE('surfgeo'); v2d=>phis + END SELECT + IF(SIZE(champ)/=SIZE(v2d)) THEN + WRITE(lunout,*) 'STARTVAR module has been initialized to the wrong size' + STOP + END IF + + champ(:,:)=v2d(:,:) + + ELSE + +!--- SOME FIELDS ARE CAUGHT: MAY BE NEEDED FOR A 3D INTEPROLATION + SELECT CASE(varname) + CASE ('surfgeo') + IF(.NOT.ALLOCATED(phis)) ALLOCATE(phis(iml,jml)) + IF(SIZE(phis)/=SIZE(champ)) THEN + WRITE(lunout,*)'STARTVAR module has been initialized to the wrong size' + STOP + END IF + phis(:,:)=champ(:,:) + END SELECT + + END IF + +END SUBROUTINE startget_phys2d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE startget_dyn(varname, lon_in, lat_in, pls,workvar,& + champ, val_exp, lon_in2, lat_in2, ibar) + + use assert_eq_m, only: assert_eq + + +!------------------------------------------------------------------------------- +! Comment: +! This routine only works if the variable does not exist or is constant. +!------------------------------------------------------------------------------- +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + REAL, INTENT(IN) :: lon_in(:) ! dim(iml) + REAL, INTENT(IN) :: lat_in(:) ! dim(jml) + REAL, INTENT(IN) :: pls(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(IN) :: workvar(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(INOUT) :: champ(:, :, :) ! dim(iml, jml, lml) + REAL, INTENT(IN) :: val_exp + REAL, INTENT(IN) :: lon_in2(:) ! dim(iml) + REAL, INTENT(IN) :: lat_in2(:) ! dim(jml2) + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" +#include "dimensions.h" +#include "comconst.h" +#include "paramet.h" +#include "comgeom2.h" + INTEGER :: iml, jml + INTEGER :: lml + INTEGER :: jml2 + REAL, DIMENSION(:,:,:), POINTER :: v3d=>NULL() + CHARACTER(LEN=10) :: vname + INTEGER :: il + REAL :: xppn, xpps +!------------------------------------------------------------------------------- + NULLIFY(v3d) + IF(MINVAL(champ)==MAXVAL(champ).AND.MINVAL(champ)==val_exp) THEN + + iml = assert_eq((/size(lon_in), size(pls, 1), size(workvar, 1), & + & size(champ, 1), size(lon_in2)/), "startget_dyn iml") + jml = assert_eq(size(lat_in), size(pls, 2), size(workvar, 2), & + & size(champ, 2), "startget_dyn jml") + lml = assert_eq(size(pls, 3), size(workvar, 3), size(champ, 3), & + & "startget_dyn lml") + jml2 = size(lat_in2) + +!--- READING UNALLOCATED FILES + IF(.NOT.ALLOCATED(psol_dyn)) & + CALL start_init_dyn(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + +!--- CHECKING IF THE FIELD IS KNOWN AND INTERPOLATING 3D FIELDS + SELECT CASE(varname) + CASE('u'); vname='U' + CASE('v'); vname='V' + CASE('t','tpot'); vname='TEMP' + CASE('q'); vname='R' + CASE DEFAULT + WRITE(lunout,*)'startget_dyn' + WRITE(lunout,*)'No rule is present to extract variable '//TRIM(varname)& + //' from any data set'; STOP + END SELECT + CALL start_inter_3d(TRIM(vname), iml, jml, lml, lon_in, lat_in, jml2, & + lon_in2, lat_in2, pls, champ,ibar ) + +!--- COMPUTING THE REQUIRED FILED + SELECT CASE(varname) + CASE('u') !--- Eastward wind + DO il=1,lml; champ(:,:,il)=champ(:,:,il)*cu(:,1:jml); END DO + champ(iml,:,:)=champ(1,:,:) + + CASE('v') !--- Northward wind + DO il=1,lml; champ(:,:,il)=champ(:,:,il)*cv(:,1:jml); END DO + champ(iml,:,:)=champ(1,:,:) + + CASE('tpot') !--- Temperature + IF(MINVAL(workvar)/=MAXVAL(workvar)) THEN + champ=champ*cpp/workvar + DO il=1,lml + xppn = SUM(aire(:,1 )*champ(:,1 ,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1 ,il) = xppn + champ(:,jml,il) = xpps + END DO + ELSE + WRITE(lunout,*)'Could not compute potential temperature as the' + WRITE(lunout,*)'Exner function is missing or constant.'; STOP + END IF + + CASE('q') !--- Relat. humidity + IF(MINVAL(workvar)/=MAXVAL(workvar)) THEN + champ=0.01*champ*workvar + WHERE(champ<0.) champ=1.0E-10 + DO il=1,lml + xppn = SUM(aire(:,1 )*champ(:,1 ,il))/apoln + xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols + champ(:,1 ,il) = xppn + champ(:,jml,il) = xpps + END DO + ELSE + WRITE(lunout,*)'Could not compute specific humidity as the' + WRITE(lunout,*)'saturated humidity is missing or constant.'; STOP + END IF + + END SELECT + + END IF + +END SUBROUTINE startget_dyn +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_orog(iml,jml,lon_in,lat_in,masque_lu) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + REAL, DIMENSION(iml,jml), INTENT(IN), OPTIONAL :: masque_lu +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: orofname + LOGICAL :: check=.TRUE. + REAL, DIMENSION(1) :: lev + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: fid, llm_tmp, ttm_tmp + REAL, DIMENSION(:,:), ALLOCATABLE :: relief_hi, tmp_var + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini +!------------------------------------------------------------------------------- + pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + + orofname = 'Relief.nc'; title='RELIEF' + IF(check) WRITE(lunout,*)'Reading the high resolution orography' + CALL flininfo(orofname, iml_rel, jml_rel, llm_tmp, ttm_tmp, fid) + + ALLOCATE(lat_rel(iml_rel,jml_rel),lon_rel(iml_rel,jml_rel)) + CALL flinopen(orofname, .FALSE., iml_rel, jml_rel, llm_tmp, lon_rel, lat_rel,& + lev, ttm_tmp, itau, date, dt, fid) + ALLOCATE(relief_hi(iml_rel,jml_rel)) + CALL flinget(fid, title, iml_rel, jml_rel, llm_tmp, ttm_tmp, 1, 1, relief_hi) + CALL flinclo(fid) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_rel),lat_ini(jml_rel)) + lon_ini(:)=lon_rel(:,1); IF(MAXVAL(lon_rel)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_rel(1,:); IF(MAXVAL(lat_rel)>pi) lat_ini=lat_ini*deg2rad + +!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS + ALLOCATE(lon_rad(iml_rel),lat_rad(jml_rel)) + CALL conf_dat2d(title, iml_rel, jml_rel, lon_ini, lat_ini, lon_rad, lat_rad, & + relief_hi, .FALSE.) + DEALLOCATE(lon_ini,lat_ini) + +!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro + IF(check) WRITE(lunout,*)'Computes all parameters needed for gravity wave dra& + &g code' + + ALLOCATE(phis(iml,jml)) ! Geopotentiel au sol + ALLOCATE(zstd(iml,jml)) ! Deviation standard de l'orographie sous-maille + ALLOCATE(zsig(iml,jml)) ! Pente de l'orographie sous-maille + ALLOCATE(zgam(iml,jml)) ! Anisotropie de l'orographie sous maille + ALLOCATE(zthe(iml,jml)) ! Orientation axe +grande pente d'oro sous maille + ALLOCATE(zpic(iml,jml)) ! Hauteur pics de la SSO + ALLOCATE(zval(iml,jml)) ! Hauteur vallees de la SSO + ALLOCATE(relief(iml,jml)) ! Orographie moyenne + ALLOCATE(masque(iml,jml)) ! Masque terre ocean + masque = -99999. + IF(PRESENT(masque_lu)) masque=masque_lu + + CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, iml-1, jml, & + lon_in, lat_in, phis, relief, zstd, zsig, zgam, zthe, zpic, zval, masque) + phis = phis * 9.81 + +!--- SURFACE ROUGHNESS COMPUTATION (UNUSED FOR THE MOMENT !!! ) + IF(check) WRITE(lunout,*)'Compute surface roughness induced by the orography' + ALLOCATE(rugo (iml ,jml)) + ALLOCATE(tmp_var(iml-1,jml)) + CALL rugsoro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, iml-1, jml, & + lon_in, lat_in, tmp_var) + rugo(1:iml-1,:)=tmp_var; rugo(iml,:)=tmp_var(1,:) + DEALLOCATE(relief_hi,tmp_var,lon_rad,lat_rad) + RETURN + +END SUBROUTINE start_init_orog +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: physfname + LOGICAL :: check=.TRUE. + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: llm_tmp, ttm_tmp + REAL, DIMENSION(:,:), ALLOCATABLE :: var_ana + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(:), ALLOCATABLE :: levphys_ini +!------------------------------------------------------------------------------- + physfname = 'ECPHY.nc'; pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + IF(check) WRITE(lunout,*)'Opening the surface analysis' + CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp, ttm_tmp, fid_phys) + + ALLOCATE(lat_phys(iml_phys,jml_phys)) + ALLOCATE(lon_phys(iml_phys,jml_phys)) + ALLOCATE(levphys_ini(llm_tmp)) + CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, llm_tmp, lon_phys, & + lat_phys, levphys_ini, ttm_tmp, itau, date, dt, fid_phys) + DEALLOCATE(levphys_ini) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_phys),lat_ini(jml_phys)) + lon_ini(:)=lon_phys(:,1); IF(MAXVAL(lon_phys)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_phys(1,:); IF(MAXVAL(lat_phys)>pi) lat_ini=lat_ini*deg2rad + + ALLOCATE(var_ana(iml_phys,jml_phys),lon_rad(iml_phys),lat_rad(jml_phys)) + +!--- SURFACE TEMPERATURE + title='ST' + ALLOCATE(tsol(iml,jml)) + CALL flinget(fid_phys,title,iml_phys,jml_phys,llm_tmp,ttm_tmp,1,1,var_ana) + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, lon_rad, lat_rad,& + var_ana , ibar ) + CALL interp_startvar(title, ibar, .TRUE., & + iml_phys, jml_phys, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, tsol) + +!--- SOIL MOISTURE + title='CDSW' + ALLOCATE(qsol(iml,jml)) + CALL flinget(fid_phys,title,iml_phys,jml_phys,llm_tmp,ttm_tmp,1,1,var_ana) + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, lon_rad, lat_rad,& + var_ana, ibar ) + CALL interp_startvar(title, ibar, .TRUE., & + iml_phys, jml_phys, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, qsol) + + CALL flinclo(fid_phys) + + DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini) + +END SUBROUTINE start_init_phys +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_init_dyn(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) +! +!------------------------------------------------------------------------------- +! Arguments: + INTEGER, INTENT(IN) :: iml, jml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + LOGICAL, INTENT(IN) :: ibar +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + CHARACTER(LEN=25) :: title + CHARACTER(LEN=120) :: physfname + LOGICAL :: check=.TRUE. + REAL :: date, dt + INTEGER, DIMENSION(1) :: itau + INTEGER :: i, j + REAL, DIMENSION(:,:), ALLOCATABLE :: var_ana, z + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(:), ALLOCATABLE :: xppn, xpps +!------------------------------------------------------------------------------- + +!--- KINETIC ENERGY + physfname = 'ECDYN.nc'; pi=2.0*ASIN(1.0); deg2rad=pi/180.0 + IF(check) WRITE(lunout,*) 'Opening the surface analysis' + CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn, ttm_dyn, fid_dyn) + IF(check) WRITE(lunout,*) 'Values read: ', iml_dyn, jml_dyn, llm_dyn, ttm_dyn + + ALLOCATE(lat_dyn(iml_dyn,jml_dyn)) + ALLOCATE(lon_dyn(iml_dyn,jml_dyn)) + ALLOCATE(levdyn_ini(llm_dyn)) + CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn, lon_dyn,lat_dyn,& + levdyn_ini, ttm_dyn, itau, date, dt, fid_dyn) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_dyn),lat_ini(jml_dyn)) + lon_ini(:)=lon_dyn(:,1); IF(MAXVAL(lon_dyn)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_dyn(1,:); IF(MAXVAL(lat_dyn)>pi) lat_ini=lat_ini*deg2rad + + ALLOCATE(var_ana(iml_dyn,jml_dyn),lon_rad(iml_dyn),lat_rad(jml_dyn)) + +!--- SURFACE GEOPOTENTIAL + title='Z' + ALLOCATE(z(iml,jml)) + CALL flinget(fid_dyn, title, iml_dyn, jml_dyn, 0, ttm_dyn, 1, 1, var_ana) + CALL conf_dat2d(title, iml_dyn, jml_dyn, lon_ini, lat_ini, lon_rad, lat_rad, & + var_ana, ibar) + CALL interp_startvar(title, ibar, .TRUE., & + iml_dyn, jml_dyn, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, z) + +!--- SURFACE PRESSURE + title='SP' + ALLOCATE(psol_dyn(iml,jml)) + CALL flinget(fid_dyn, title, iml_dyn, jml_dyn, 0, ttm_dyn, 1, 1, var_ana) + CALL conf_dat2d(title, iml_dyn, jml_dyn, lon_ini, lat_ini, lon_rad, lat_rad, & + var_ana, ibar) + CALL interp_startvar(title, ibar, .TRUE., & + iml_dyn, jml_dyn, lon_rad, lat_rad, var_ana, iml, jml, jml-1, & + lon_in, lat_in, lon_in2, lat_in2, psol_dyn) + + DEALLOCATE(var_ana,lon_rad,lat_rad,lon_ini,lat_ini) + +!--- ALLOCATION OF VARIABLES CREATED IN OR COMING FROM RESTART FILE + IF(.NOT.ALLOCATED(tsol)) THEN + CALL start_init_phys(iml,jml,lon_in,lat_in,jml2,lon_in2,lat_in2,ibar) + ELSE + IF(SIZE(tsol)/=SIZE(psol_dyn)) THEN + WRITE(lunout,*)'start_init_dyn :' + WRITE(lunout,*)'The temperature field we have does not have the right size' + STOP + END IF + END IF + + IF(.NOT.ALLOCATED(phis)) THEN + CALL start_init_orog(iml,jml,lon_in,lat_in) + ELSE + IF(SIZE(phis)/=SIZE(psol_dyn)) THEN + WRITE(lunout,*)'start_init_dyn :' + WRITE(lunout,*)'The orography field we have does not have the right size' + STOP + END IF + END IF + +!--- PSOL IS COMPUTED IN PASCALS + DO j = 1, jml + DO i = 1, iml-1 + psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j))/287.0/tsol(i,j)) + END DO + psol_dyn(iml,j) = psol_dyn(1,j) + END DO + DEALLOCATE(z) + + ALLOCATE(xppn(iml-1),xpps(iml-1)) + DO i = 1, iml-1 + xppn(i) = aire( i,1) * psol_dyn( i,1) + xpps(i) = aire( i,jml) * psol_dyn( i,jml) + END DO + DO i = 1, iml + psol_dyn(i,1 ) = SUM(xppn)/apoln + psol_dyn(i,jml) = SUM(xpps)/apols + END DO + DEALLOCATE(xppn,xpps) + + RETURN + +END SUBROUTINE start_init_dyn +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in, lat_in, jml2, & + lon_in2, lat_in2, pls_in, var3d, ibar) + + use pchsp_95_m, only: pchsp_95 + use pchfe_95_m, only: pchfe_95 + +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: varname + INTEGER, INTENT(IN) :: iml, jml, lml + REAL, DIMENSION(iml), INTENT(IN) :: lon_in + REAL, DIMENSION(jml), INTENT(IN) :: lat_in + INTEGER, INTENT(IN) :: jml2 + REAL, DIMENSION(iml), INTENT(IN) :: lon_in2 + REAL, DIMENSION(jml2), INTENT(IN) :: lat_in2 + REAL, DIMENSION(iml, jml, lml), INTENT(IN) :: pls_in + REAL, DIMENSION(iml, jml, lml), INTENT(OUT) :: var3d + LOGICAL, INTENT(IN) :: ibar +!---------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + LOGICAL:: check=.TRUE., skip + REAL chmin, chmax + INTEGER ii, ij, il, ierr + integer n_extrap ! number of extrapolated points + REAL, DIMENSION(iml, jml, llm_dyn):: var_tmp3d + REAL, DIMENSION(:), ALLOCATABLE :: lon_rad, lat_rad, lon_ini, lat_ini + REAL, DIMENSION(llm_dyn):: lev_dyn, ax, ay, yder + +!--------------------------------------------------------------------------- + IF(check) WRITE(lunout, *)'Going into flinget to extract the 3D field.' + IF(check) WRITE(lunout, *) fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, & + ttm_dyn + IF(check) WRITE(lunout, *) 'Allocating space for interpolation', iml, jml, & + llm_dyn + + IF(.NOT.ALLOCATED(var_ana3d)) ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn)) + CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, ttm_dyn, 1, 1, & + var_ana3d) + +!--- IF ANGLES ARE IN DEGREES, THEY ARE CONVERTED INTO RADIANS + ALLOCATE(lon_ini(iml_dyn), lat_ini(jml_dyn)) + lon_ini(:)=lon_dyn(:, 1); IF(MAXVAL(lon_dyn)>pi) lon_ini=lon_ini*deg2rad + lat_ini(:)=lat_dyn(1, :); IF(MAXVAL(lat_dyn)>pi) lat_ini=lat_ini*deg2rad + +!--- FIELDS ARE PROCESSED TO BE ON STANDARD ANGULAR DOMAINS + ALLOCATE(lon_rad(iml_dyn), lat_rad(jml_dyn)) + CALL conf_dat3d (varname, iml_dyn, jml_dyn, llm_dyn, lon_ini, lat_ini, & + levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d, ibar) + DEALLOCATE(lon_ini, lat_ini) + +!--- COMPUTING THE REQUIRED FIELDS USING ROUTINE grid_noro + DO il=1, llm_dyn + CALL interp_startvar(varname, ibar, il==1, iml_dyn, jml_dyn, lon_rad, & + lat_rad, var_ana3d(:, :, il), iml, jml, jml2, lon_in, lat_in, & + lon_in2, lat_in2, var_tmp3d(:, :, il)) + END DO + DEALLOCATE(lon_rad, lat_rad) + +!--- VERTICAL INTERPOLATION IS PERFORMED FROM TOP OF ATMOSPHERE TO GROUND + ax = lev_dyn(llm_dyn:1:-1) + skip = .false. + n_extrap = 0 + DO ij=1, jml + DO ii=1, iml-1 + ay = var_tmp3d(ii, ij, llm_dyn:1:-1) + yder = pchsp_95(ax, ay, ibeg=2, iend=2, vc_beg=0., vc_end=0.) + CALL pchfe_95(ax, ay, yder, skip, pls_in(ii, ij, lml:1:-1), & + var3d(ii, ij, lml:1:-1), ierr) + if (ierr < 0) stop 1 + n_extrap = n_extrap + ierr + END DO + END DO + if (n_extrap /= 0) then + print *, "start_inter_3d pchfe_95: n_extrap = ", n_extrap + end if + var3d(iml, :, :) = var3d(1, :, :) + + DO il=1, lml + CALL minmax(iml*jml, var3d(1, 1, il), chmin, chmax) + WRITE(lunout, *)' '//TRIM(varname)//' min max l ', il, chmin, chmax + END DO + +END SUBROUTINE start_inter_3d +! +!------------------------------------------------------------------------------- + + +!------------------------------------------------------------------------------- +! +SUBROUTINE interp_startvar(vname, ibar, ibeg, ii, jj, lon, lat, vari, & + i1, j1, j2, lon1, lat1, lon2, lat2, varo) +! +!------------------------------------------------------------------------------- + + USE inter_barxy_m, only: inter_barxy + +! Arguments: + CHARACTER(LEN=*), INTENT(IN) :: vname + LOGICAL, INTENT(IN) :: ibar, ibeg + INTEGER, INTENT(IN) :: ii, jj + REAL, DIMENSION(ii), INTENT(IN) :: lon + REAL, DIMENSION(jj), INTENT(IN) :: lat + REAL, DIMENSION(ii,jj), INTENT(IN) :: vari + INTEGER, INTENT(IN) :: i1, j1, j2 + REAL, DIMENSION(i1), INTENT(IN) :: lon1 + REAL, DIMENSION(j1), INTENT(IN) :: lat1 + REAL, DIMENSION(i1), INTENT(IN) :: lon2 + REAL, DIMENSION(j2), INTENT(IN) :: lat2 + REAL, DIMENSION(i1,j1), INTENT(OUT) :: varo +!------------------------------------------------------------------------------- +! Local variables: +#include "iniprint.h" + REAL, DIMENSION(i1-1,j1) :: vtmp +!------------------------------------------------------------------------------- + IF(ibar) THEN + IF(ibeg) THEN + WRITE(lunout,*) & + '---------------------------------------------------------------' + WRITE(lunout,*) & + '$$$ Utilisation de l interpolation barycentrique pour '//TRIM(vname)//' $$$' + WRITE(lunout,*) & + '---------------------------------------------------------------' + END IF + CALL inter_barxy(lon, lat(:jj-1), vari, lon2(:i1-1), lat2(:j2), vtmp) + ELSE + CALL grille_m (ii, jj, lon, lat, vari, i1-1, j1, lon1, lat1, vtmp) + END IF + CALL gr_int_dyn(vtmp, varo, i1-1, j1) + +END SUBROUTINE interp_startvar +! +!------------------------------------------------------------------------------- + +#endif +! of #ifdef CPP_EARTH + +END MODULE startvar +! +!******************************************************************************* Index: LMDZ5/trunk/libf/dyn3d_common/test_period.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/test_period.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/test_period.F (revision 1952) @@ -0,0 +1,116 @@ +! +! $Header$ +! + SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis ) +c +c Auteur : P. Le Van +c --------- +c .... Cette routine teste la periodicite en longitude des champs ucov, +c teta, q , p et phis .......... +c + USE infotrac, ONLY : nqtot +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c +c ...... Arguments ...... +c + REAL ucov(ip1jmp1,llm), vcov(ip1jm,llm), teta(ip1jmp1,llm) , + , q(ip1jmp1,llm,nqtot), p(ip1jmp1,llmp1), phis(ip1jmp1) +c +c ..... Variables locales ..... +c + INTEGER ij,l,nq +c + DO l = 1, llm + DO ij = 1, ip1jmp1, iip1 + IF( ucov(ij,l).NE.ucov(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- UCOV --- n est pas', + , ' periodique en longitude ! ' + PRINT *,' l, ij = ', l, ij, ij+iim + STOP + ENDIF + IF( teta(ij,l).NE.teta(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- TETA --- n est pas', + , ' periodique en longitude ! ' + PRINT *,' l, ij = ', l, ij, ij+iim + , , teta(ij,l), teta(ij+iim,l) + STOP + ENDIF + ENDDO + + do ij=1,iim + if (teta(ij,l).ne.teta(1,l) + s .or.teta(ip1jm+ij,l).ne.teta(ip1jm+1,l) ) then + PRINT *,'STOP dans test_period car --- TETA --- n est pas', + , ' constant aux poles ! ' + print*,'teta(',1 ,',',l,')=',teta(1 ,l) + print*,'teta(',ij,',',l,')=',teta(ij,l) + print*,'teta(',ip1jm+1 ,',',l,')=',teta(ip1jm+1 ,l) + print*,'teta(',ip1jm+ij,',',l,')=',teta(ip1jm+ij,l) + stop + endif + enddo + ENDDO + +c + DO l = 1, llm + DO ij = 1, ip1jm, iip1 + IF( vcov(ij,l).NE.vcov(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- VCOV --- n est pas', + , ' periodique en longitude !' + PRINT *,' l, ij = ', l, ij, ij+iim,vcov(ij+iim,l),vcov(ij,l) + vcov(ij+iim,l)=vcov(ij,l) +c STOP + ENDIF + ENDDO + ENDDO + +c + DO nq =1, nqtot + DO l =1, llm + DO ij = 1, ip1jmp1, iip1 + IF( q(ij,l,nq).NE.q(ij+iim,l,nq) ) THEN + PRINT *,'STOP dans test_period car --- Q --- n est pas ', + , 'periodique en longitude !' + PRINT *,' nq , l, ij = ', nq, l, ij, ij+iim + STOP + ENDIF + ENDDO + ENDDO + ENDDO +c + DO l = 1, llm + DO ij = 1, ip1jmp1, iip1 + IF( p(ij,l).NE.p(ij+iim,l) ) THEN + PRINT *,'STOP dans test_period car --- P --- n est pas', + , ' periodique en longitude !' + PRINT *,' l ij = ',l, ij, ij+iim + STOP + ENDIF + IF( phis(ij).NE.phis(ij+iim) ) THEN + PRINT *,'STOP dans test_period car --- PHIS --- n est pas', + , ' periodique en longitude ! l, IJ = ', l, ij,ij+iim + PRINT *,' ij = ', ij, ij+iim + STOP + ENDIF + ENDDO + do ij=1,iim + if (p(ij,l).ne.p(1,l) + s .or.p(ip1jm+ij,l).ne.p(ip1jm+1,l) ) then + PRINT *,'STOP dans test_period car --- P --- n est pas', + , ' constant aux poles ! ' + print*,'p(',1 ,',',l,')=',p(1 ,l) + print*,'p(',ij,',',l,')=',p(ij,l) + print*,'p(',ip1jm+1 ,',',l,')=',p(ip1jm+1 ,l) + print*,'p(',ip1jm+ij,',',l,')=',p(ip1jm+ij,l) + stop + endif + enddo + ENDDO +c +c + RETURN + END Index: LMDZ5/trunk/libf/dyn3d_common/traceurpole.F =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/traceurpole.F (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/traceurpole.F (revision 1952) @@ -0,0 +1,70 @@ +! +! $Id$ +! + subroutine traceurpole(q,masse) + + USE control_mod + + implicit none + +#include "dimensions.h" +c#include "paramr2.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissip.h" +#include "comvert.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" + + +c Arguments + integer iq + real masse(iip1,jjp1,llm) + real q(iip1,jjp1,llm) + + +c Locals + integer i,j,l + real sommemassen(llm) + real sommemqn(llm) + real sommemasses(llm) + real sommemqs(llm) + real qpolen(llm),qpoles(llm) + + +c On impose une seule valeur au pôle Sud j=jjm+1=jjp1 + sommemasses=0 + sommemqs=0 + do l=1,llm + do i=1,iip1 + sommemasses(l)=sommemasses(l)+masse(i,jjp1,l) + sommemqs(l)=sommemqs(l)+masse(i,jjp1,l)*q(i,jjp1,l) + enddo + qpoles(l)=sommemqs(l)/sommemasses(l) + enddo + +c On impose une seule valeur du traceur au pôle Nord j=1 + sommemassen=0 + sommemqn=0 + do l=1,llm + do i=1,iip1 + sommemassen(l)=sommemassen(l)+masse(i,1,l) + sommemqn(l)=sommemqn(l)+masse(i,1,l)*q(i,1,l) + enddo + qpolen(l)=sommemqn(l)/sommemassen(l) + enddo + +c On force le traceur à prendre cette valeur aux pôles + do l=1,llm + do i=1,iip1 + q(i,1,l)=qpolen(l) + q(i,jjp1,l)=qpoles(l) + enddo + enddo + + + return + end Index: LMDZ5/trunk/libf/dyn3d_common/ugeostr.F90 =================================================================== --- LMDZ5/trunk/libf/dyn3d_common/ugeostr.F90 (revision 1952) +++ LMDZ5/trunk/libf/dyn3d_common/ugeostr.F90 (revision 1952) @@ -0,0 +1,68 @@ +! +! $Id$ +! +subroutine ugeostr(phi,ucov) + + ! Calcul du vent covariant geostrophique a partir du champ de + ! geopotentiel. + ! We actually compute: (1 - cos^8 \phi) u_g + ! to have a wind going smoothly to 0 at the equator. + ! We assume that the surface pressure is uniform so that model + ! levels are pressure levels. + + implicit none + + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "comgeom2.h" + + real ucov(iip1,jjp1,llm),phi(iip1,jjp1,llm) + real um(jjm,llm),fact,u(iip1,jjm,llm) + integer i,j,l + + real zlat + + um(:,:)=0 ! initialize um() + + DO j=1,jjm + + if (abs(sin(rlatv(j))).lt.1.e-4) then + zlat=1.e-4 + else + zlat=rlatv(j) + endif + fact=cos(zlat) + fact=fact*fact + fact=fact*fact + fact=fact*fact + fact=(1.-fact)/ & + (2.*omeg*sin(zlat)*(rlatu(j+1)-rlatu(j))) + fact=-fact/rad + DO l=1,llm + DO i=1,iim + u(i,j,l)=fact*(phi(i,j+1,l)-phi(i,j,l)) + um(j,l)=um(j,l)+u(i,j,l)/REAL(iim) + ENDDO + ENDDO + ENDDO + call dump2d(jjm,llm,um,'Vent-u geostrophique') + + ! calcul des champ de vent: + + DO l=1,llm + DO i=1,iip1 + ucov(i,1,l)=0. + ucov(i,jjp1,l)=0. + end DO + DO j=2,jjm + DO i=1,iim + ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j) + end DO + ucov(iip1,j,l)=ucov(1,j,l) + end DO + end DO + + print *, 301 + +end subroutine ugeostr