Index: /LMDZ5/trunk/libf/dyn3dmem/PVtheta.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/PVtheta.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/PVtheta.F (revision 1632) @@ -0,0 +1,196 @@ + SUBROUTINE PVtheta(ilon,ilev,pucov,pvcov,pteta, + $ ztfi,zplay,zplev, + $ nbteta,theta,PVteta) + IMPLICIT none + +c======================================================================= +c +c Auteur: I. Musat +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c Calcul de la vorticite potentielle PVteta sur des iso-theta selon +c la methodologie du NCEP/NCAR : +c 1) on calcule la stabilite statique N**2=g/T*(dT/dz+g/cp) sur les +c niveaux du modele => N2 +c 2) on interpole les vents, la temperature et le N**2 sur des isentropes +c (en fait sur des iso-theta) lineairement en log(theta) => +c ucovteta, vcovteta, N2teta +c 3) on calcule la vorticite absolue sur des iso-theta => vorateta +c 4) on calcule la densite rho sur des iso-theta => rhoteta +c +c rhoteta = (T/theta)**(cp/R)*p0/(R*T) +c +c 5) on calcule la vorticite potentielle sur des iso-theta => PVteta +c +c PVteta = (vorateta * N2 * theta)/(g * rhoteta) ! en PVU +c +c NB: 1PVU=10**(-6) K*m**2/(s * kg) +c +c PVteta = vorateta * N2/(g**2 * rhoteta) ! en 1/(Pa*s) +c +c +c ******************************************************************* +c +c +c Variables d'entree : ilon,ilev,pucov,pvcov,pteta,ztfi,zplay,zplev,nbteta,theta +c -> sur la grille dynamique +c Variable de sortie : PVteta +c -> sur la grille physique +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +c +c variables Input +c + INTEGER ilon, ilev + REAL pvcov(iip1,jjm,ilev) + REAL pucov(iip1,jjp1,ilev) + REAL pteta(iip1,jjp1,ilev) + REAL ztfi(ilon,ilev) + REAL zplay(ilon,ilev), zplev(ilon,ilev+1) + INTEGER nbteta + REAL theta(nbteta) +c +c variable Output +c + REAL PVteta(ilon,nbteta) +c +c variables locales +c + INTEGER i, j, l, ig0 + REAL SSUM + REAL teta(ilon, ilev) + REAL ptetau(ip1jmp1, ilev), ptetav(ip1jm, ilev) + REAL ucovteta(ip1jmp1,ilev), vcovteta(ip1jm,ilev) + REAL N2(ilon,ilev-1), N2teta(ilon,nbteta) + REAL ztfiteta(ilon,nbteta) + REAL rhoteta(ilon,nbteta) + REAL vorateta(iip1,jjm,nbteta) + REAL voratetafi(ilon,nbteta), vorpol(iim) +c +#include "comgeom2.h" +#include "comconst.h" +#include "comvert.h" +c +c projection teta sur la grille physique +c + DO l=1,llm + teta(1,l) = pteta(1,1,l) + ig0 = 2 + DO j = 2, jjm + DO i = 1, iim + teta(ig0,l) = pteta(i,j,l) + ig0 = ig0 + 1 + ENDDO + ENDDO + teta(ig0,l) = pteta(1,jjp1,l) + ENDDO +c +c calcul pteta sur les grilles U et V +c + DO l=1, llm + DO j=1, jjp1 + DO i=1, iip1 + ig0=i+(j-1)*iip1 + ptetau(ig0,l)=pteta(i,j,l) + ENDDO !i + ENDDO !j + DO j=1, jjm + DO i=1, iip1 + ig0=i+(j-1)*iip1 + ptetav(ig0,l)=0.5*(pteta(i,j,l)+pteta(i,j+1,l)) + ENDDO !i + ENDDO !j + ENDDO !l +c +c projection pucov, pvcov sur une surface de theta constante +c + DO l=1, nbteta +cIM 1rout CALL tetaleveli1j1(ip1jmp1,llm,.true.,ptetau,theta(l), + CALL tetalevel(ip1jmp1,llm,.true.,ptetau,theta(l), + . pucov,ucovteta(:,l)) +cIM 1rout CALL tetaleveli1j(ip1jm,llm,.true.,ptetav,theta(l), + CALL tetalevel(ip1jm,llm,.true.,ptetav,theta(l), + . pvcov,vcovteta(:,l)) + ENDDO !l +c +c calcul vorticite absolue sur une iso-theta : vorateta +c + CALL tourabs(nbteta,vcovteta,ucovteta,vorateta) +c +c projection vorateta sur la grille physique => voratetafi +c + DO l=1,nbteta + DO j=2,jjm + ig0=1+(j-2)*iim + DO i=1,iim + voratetafi(ig0+i+1,l) = vorateta( i ,j-1,l) * alpha4(i+1,j) + + $ vorateta(i+1,j-1,l) * alpha1(i+1,j) + + $ vorateta(i ,j ,l) * alpha3(i+1,j) + + $ vorateta(i+1,j ,l) * alpha2(i+1,j) + ENDDO + voratetafi(ig0 +1,l) = voratetafi(ig0 +1+ iim,l) + ENDDO + ENDDO +c + DO l=1,nbteta + DO i=1,iim + vorpol(i) = vorateta(i,1,l)*aire(i,1) + ENDDO + voratetafi(1,l)= SSUM(iim,vorpol,1)/apoln + ENDDO +c + DO l=1,nbteta + DO i=1,iim + vorpol(i) = vorateta(i,jjm,l)* aire(i,jjm +1) + ENDDO + voratetafi(ilon,l)= SSUM(iim,vorpol,1)/apols + ENDDO +c +c calcul N**2 sur la grille physique => N2 +c + DO l=1, llm-1 + DO i=1, ilon + N2(i,l) = (g**2 * zplay(i,l) * + $ (ztfi(i,l+1)-ztfi(i,l)) )/ + $ (R*ztfi(i,l)*ztfi(i,l)* + $ (zplev(i,l)-zplev(i,l+1)) )+ + $ (g**2)/(ztfi(i,l)*CPP) + ENDDO !i + ENDDO !l +c +c calcul N2 sur une iso-theta => N2teta +c + DO l=1, nbteta + CALL tetalevel(ilon,llm-1,.true.,teta,theta(l), + $ N2,N2teta(:,l)) + CALL tetalevel(ilon,llm,.true.,teta,theta(l), + $ ztfi,ztfiteta(:,l)) + ENDDO !l=1, nbteta +c +c calcul rho et PV sur une iso-theta : rhoteta, PVteta +c + DO l=1, nbteta + DO i=1, ilon + rhoteta(i,l)=(ztfiteta(i,l)/theta(l))**(CPP/R)* + $ (preff/(R*ztfiteta(i,l))) +c +c PVteta en PVU +c + PVteta(i,l)=(theta(l)*g*voratetafi(i,l)*N2teta(i,l))/ + $ (g**2*rhoteta(i,l)) +c +c PVteta en 1/(Pa*s) +c + PVteta(i,l)=(voratetafi(i,l)*N2teta(i,l))/ + $ (g**2*rhoteta(i,l)) + ENDDO !i + ENDDO !l +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/abort_gcm.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/abort_gcm.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/abort_gcm.F (revision 1632) @@ -0,0 +1,51 @@ +! +! $Id: abort_gcm.F 1279 2009-12-10 09:02:56Z fairhead $ +! +c +c + SUBROUTINE abort_gcm(modname, message, ierr) + +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin_dump + USE ioipsl_getincom +#endif + USE parallel +#include "iniprint.h" + +C +C Stops the simulation cleanly, closing files and printing various +C comments +C +C Input: modname = name of calling program +C message = stuff to print +C ierr = severity of situation ( = 0 normal ) + + character (len=*) :: modname + integer ierr + character (len=*) :: message + + write(lunout,*) 'in abort_gcm' +#ifdef CPP_IOIPSL +c$OMP MASTER + call histclo + call restclo + if (MPI_rank .eq. 0) then + call getin_dump + endif +c$OMP END MASTER +#endif +c call histclo(2) +c call histclo(3) +c call histclo(4) +c call histclo(5) + write(lunout,*) 'Stopping in ', modname + write(lunout,*) 'Reason = ',message + if (ierr .eq. 0) then + write(lunout,*) 'Everything is cool' + else + write(lunout,*) 'Houston, we have a problem ', ierr + STOP + endif + END Index: /LMDZ5/trunk/libf/dyn3dmem/academic.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/academic.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/academic.h (revision 1632) @@ -0,0 +1,5 @@ +! +! $Header$ +! + real tetarappel(ip1jmp1,llm),taurappel + common/academic/tetarappel,taurappel Index: /LMDZ5/trunk/libf/dyn3dmem/adaptdt.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/adaptdt.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/adaptdt.F (revision 1632) @@ -0,0 +1,60 @@ +! +! $Id: adaptdt.F 1299 2010-01-20 14:27:21Z fairhead $ +! + 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/dyn3dmem/addfi_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/addfi_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/addfi_loc.F (revision 1632) @@ -0,0 +1,246 @@ +! +! $Header$ +! + SUBROUTINE addfi_loc(pdt, leapf, forward, + S pucov, pvcov, pteta, pq , pps , + S pdufi, pdvfi, pdhfi,pdqfi, pdpfi ) + USE parallel + USE infotrac, ONLY : nqtot + IMPLICIT NONE +c +c======================================================================= +c +c Addition of the physical tendencies +c +c Interface : +c ----------- +c +c Input : +c ------- +c pdt time step of integration +c leapf logical +c forward logical +c pucov(ip1jmp1,llm) first component of the covariant velocity +c pvcov(ip1ip1jm,llm) second component of the covariant velocity +c pteta(ip1jmp1,llm) potential temperature +c pts(ip1jmp1,llm) surface temperature +c pdufi(ip1jmp1,llm) | +c pdvfi(ip1jm,llm) | respective +c pdhfi(ip1jmp1) | tendencies +c pdtsfi(ip1jmp1) | +c +c Output : +c -------- +c pucov +c pvcov +c ph +c pts +c +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "serre.h" +c +c Arguments : +c ----------- +c + REAL pdt +c + REAL pvcov(ijb_v:ije_v,llm),pucov(ijb_u:ije_u,llm) + REAL pteta(ijb_u:ije_u,llm),pq(ijb_u:ije_u,llm,nqtot) + REAL pps(ijb_u:ije_u) +c + REAL pdvfi(ijb_v:ije_v,llm),pdufi(ijb_u:ije_u,llm) + REAL pdqfi(ijb_u:ije_u,llm,nqtot),pdhfi(ijb_u:ije_u,llm) + REAL pdpfi(ijb_u:ije_u) +c + LOGICAL leapf,forward +c +c +c Local variables : +c ----------------- +c + REAL xpn(iim),xps(iim),tpn,tps + INTEGER j,k,iq,ij + REAL qtestw, qtestt + PARAMETER ( qtestw = 1.0e-15 ) + PARAMETER ( qtestt = 1.0e-40 ) + + REAL SSUM + EXTERNAL SSUM + + INTEGER :: ijb,ije +c +c----------------------------------------------------------------------- + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + + if (pole_nord) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pteta( ij ,k) + ENDDO + tpn = SSUM(iim,xpn,1)/ apoln + + DO ij = 1, iip1 + pteta( ij ,k) = tpn + ENDDO + ENDDO +c$OMP END DO NOWAIT + endif + + if (pole_sud) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k) + ENDDO + tps = SSUM(iim,xps,1)/ apols + + DO ij = 1, iip1 + pteta(ij+ip1jm,k) = tps + ENDDO + ENDDO +c$OMP END DO NOWAIT + endif +c + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + + if (pole_nord) ijb=ij_begin + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c + if (pole_sud) ije=ij_end +c$OMP MASTER + DO j = ijb,ije + pps(j) = pps(j) + pdpfi(j) * pdt + ENDDO +c$OMP END MASTER + + DO iq = 1, 2 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + + DO iq = 3, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + +c$OMP MASTER + if (pole_nord) then + + DO ij = 1, iim + xpn(ij) = aire( ij ) * pps( ij ) + ENDDO + + tpn = SSUM(iim,xpn,1)/apoln + + DO ij = 1, iip1 + pps ( ij ) = tpn + ENDDO + + endif + + if (pole_sud) then + + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm ) + ENDDO + + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pps ( ij+ip1jm ) = tps + ENDDO + + endif +c$OMP END MASTER + + if (pole_nord) then + DO iq = 1, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pq( ij ,k,iq) + ENDDO + tpn = SSUM(iim,xpn,1)/apoln + + DO ij = 1, iip1 + pq ( ij ,k,iq) = tpn + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + endif + + if (pole_sud) then + DO iq = 1, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq) + ENDDO + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pq (ij+ip1jm,k,iq) = tps + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + endif + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/addfi_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/addfi_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/addfi_p.F (revision 1632) @@ -0,0 +1,244 @@ +! +! $Header$ +! + SUBROUTINE addfi_p(pdt, leapf, forward, + S pucov, pvcov, pteta, pq , pps , + S pdufi, pdvfi, pdhfi,pdqfi, pdpfi ) + USE parallel + USE infotrac, ONLY : nqtot + IMPLICIT NONE +c +c======================================================================= +c +c Addition of the physical tendencies +c +c Interface : +c ----------- +c +c Input : +c ------- +c pdt time step of integration +c leapf logical +c forward logical +c pucov(ip1jmp1,llm) first component of the covariant velocity +c pvcov(ip1ip1jm,llm) second component of the covariant velocity +c pteta(ip1jmp1,llm) potential temperature +c pts(ip1jmp1,llm) surface temperature +c pdufi(ip1jmp1,llm) | +c pdvfi(ip1jm,llm) | respective +c pdhfi(ip1jmp1) | tendencies +c pdtsfi(ip1jmp1) | +c +c Output : +c -------- +c pucov +c pvcov +c ph +c pts +c +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "serre.h" +c +c Arguments : +c ----------- +c + REAL pdt +c + REAL pvcov(ip1jm,llm),pucov(ip1jmp1,llm) + REAL pteta(ip1jmp1,llm),pq(ip1jmp1,llm,nqtot),pps(ip1jmp1) +c + REAL pdvfi(ip1jm,llm),pdufi(ip1jmp1,llm) + REAL pdqfi(ip1jmp1,llm,nqtot),pdhfi(ip1jmp1,llm),pdpfi(ip1jmp1) +c + LOGICAL leapf,forward +c +c +c Local variables : +c ----------------- +c + REAL xpn(iim),xps(iim),tpn,tps + INTEGER j,k,iq,ij + REAL qtestw, qtestt + PARAMETER ( qtestw = 1.0e-15 ) + PARAMETER ( qtestt = 1.0e-40 ) + + REAL SSUM + EXTERNAL SSUM + + INTEGER :: ijb,ije +c +c----------------------------------------------------------------------- + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pteta(j,k)= pteta(j,k) + pdhfi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + + if (pole_nord) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pteta( ij ,k) + ENDDO + tpn = SSUM(iim,xpn,1)/ apoln + + DO ij = 1, iip1 + pteta( ij ,k) = tpn + ENDDO + ENDDO +c$OMP END DO NOWAIT + endif + + if (pole_sud) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pteta(ij+ip1jm,k) + ENDDO + tps = SSUM(iim,xps,1)/ apols + + DO ij = 1, iip1 + pteta(ij+ip1jm,k) = tps + ENDDO + ENDDO +c$OMP END DO NOWAIT + endif +c + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pucov(j,k)= pucov(j,k) + pdufi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + + if (pole_nord) ijb=ij_begin + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pvcov(j,k)= pvcov(j,k) + pdvfi(j,k) * pdt + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c + if (pole_sud) ije=ij_end +c$OMP MASTER + DO j = ijb,ije + pps(j) = pps(j) + pdpfi(j) * pdt + ENDDO +c$OMP END MASTER + + DO iq = 1, 2 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestw ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + + DO iq = 3, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1,llm + DO j = ijb,ije + pq(j,k,iq)= pq(j,k,iq) + pdqfi(j,k,iq) * pdt + pq(j,k,iq)= AMAX1( pq(j,k,iq), qtestt ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + +c$OMP MASTER + if (pole_nord) then + + DO ij = 1, iim + xpn(ij) = aire( ij ) * pps( ij ) + ENDDO + + tpn = SSUM(iim,xpn,1)/apoln + + DO ij = 1, iip1 + pps ( ij ) = tpn + ENDDO + + endif + + if (pole_sud) then + + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pps(ij+ip1jm ) + ENDDO + + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pps ( ij+ip1jm ) = tps + ENDDO + + endif +c$OMP END MASTER + + if (pole_nord) then + DO iq = 1, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xpn(ij) = aire( ij ) * pq( ij ,k,iq) + ENDDO + tpn = SSUM(iim,xpn,1)/apoln + + DO ij = 1, iip1 + pq ( ij ,k,iq) = tpn + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + endif + + if (pole_sud) then + DO iq = 1, nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO k = 1, llm + DO ij = 1, iim + xps(ij) = aire(ij+ip1jm) * pq(ij+ip1jm,k,iq) + ENDDO + tps = SSUM(iim,xps,1)/apols + + DO ij = 1, iip1 + pq (ij+ip1jm,k,iq) = tps + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDDO + endif + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/advect_new_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advect_new_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advect_new_loc.F (revision 1632) @@ -0,0 +1,295 @@ +! +! $Header$ +! + SUBROUTINE advect_new_loc(ucov,vcov,teta,w,massebx,masseby, + & du,dv,dteta) + USE parallel + USE write_field_loc + USE advect_new_mod + IMPLICIT NONE +c======================================================================= +c +c Auteurs: P. Le Van , Fr. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ************************************************************* +c .... calcul des termes d'advection vertic.pour u,v,teta,q ... +c ************************************************************* +c ces termes sont ajoutes a du,dv,dteta et dq . +c Modif F.Forget 03/94 : on retire q de advect +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "ener.h" + +c Arguments: +c ---------- + + REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) + REAL teta(ijb_u:ije_u,llm) + REAL massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm) + REAL w(ijb_u:ije_u,llm) + REAL dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm) + REAL dteta(ijb_u:ije_u,llm) +c Local: +c ------ + + REAL wsur2(ijb_u:ije_u) + REAL unsaire2(ijb_u:ije_u), ge(ijb_u:ije_u) + REAL deuxjour, ww, gt, uu, vv + + INTEGER ij,l,ijb,ije + EXTERNAL SSUM + REAL SSUM + + + +c----------------------------------------------------------------------- +c 2. Calculs preliminaires: +c ------------------------- + + IF (conser) THEN + deuxjour = 2. * daysec + + DO 1 ij = 1, ip1jmp1 + unsaire2(ij) = unsaire(ij) * unsaire(ij) + 1 CONTINUE + END IF + + +c------------------ -yy ---------------------------------------------- +c . Calcul de u + +c$OMP MASTER + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO ij=ijb,ije + du2(ij,1)=0. + du1(ij,llm)=0. + ENDDO + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dv2(ij,1)=0. + dv1(ij,llm)=0. + ENDDO + + ijb=ij_begin + ije=ij_end + + DO ij=ijb,ije + dteta2(ij,1)=0. + dteta1(ij,llm)=0. + ENDDO +c$OMP END MASTER +c$OMP BARRIER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c DO ij = iip2, ip1jmp1 +c uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) ) +c ENDDO + +c DO ij = iip2, ip1jm +c uav(ij,l) = uav(ij,l) + uav(ij+iip1,l) +c ENDDO + + DO ij = ijb, ije + + uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) + . +0.25*(ucov(ij+iip1,l)+ucov(ij,l)) + ENDDO + + if (pole_nord) then + DO ij = 1, iip1 + uav(ij ,l) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iip1 + uav(ip1jm+ij,l) = 0. + ENDDO + endif + + ENDDO +c$OMP END DO +c call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/))) + +c------------------ -xx ---------------------------------------------- +c . Calcul de v + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + DO ij = ijb+1, ije + vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) ) + ENDDO + + DO ij = ijb,ije,iip1 + vav(ij,l) = vav(ij+iim,l) + ENDDO + + + DO ij = ijb, ije-1 + vav(ij,l) = vav(ij,l) + vav(ij+1,l) + ENDDO + + DO ij = ijb, ije, iip1 + vav(ij+iim,l) = vav(ij,l) + ENDDO + + ENDDO +c$OMP END DO +c call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/))) + +c----------------------------------------------------------------------- +c$OMP BARRIER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 20 l = 1, llmm1 + + +c ...... calcul de - w/2. au niveau l+1 ....... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO 5 ij = ijb, ije + wsur2( ij ) = - 0.5 * w( ij,l+1 ) + 5 CONTINUE + + +c ..................... calcul pour du .................. + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO 6 ij = ijb ,ije-1 + ww = wsur2 ( ij ) + wsur2( ij+1 ) + uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) + du1(ij,l) = ww * ( uu - uav(ij, l ) )/massebx(ij, l ) + du2(ij,l+1)= ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) + 6 CONTINUE + +c ................. calcul pour dv ..................... + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 8 ij = ijb, ije + ww = wsur2( ij+iip1 ) + wsur2( ij ) + vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) + dv1(ij,l) = ww * (vv - vav(ij, l ) )/masseby(ij, l ) + dv2(ij,l+1)= ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) + 8 CONTINUE + +c + +c ............................................................ +c ............... calcul pour dh ................... +c ............................................................ + +c ---z +c calcul de - d( teta * w ) qu'on ajoute a dh +c ............... + ijb=ij_begin + ije=ij_end + + DO 15 ij = ijb, ije + ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) + dteta1(ij, l ) = ww + dteta2(ij,l+1) = ww + 15 CONTINUE + +c ym ---> conser a voir plus tard + +c IF( conser) THEN +c +c DO 17 ij = 1,ip1jmp1 +c ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) +c 17 CONTINUE +c gt = SSUM( ip1jmp1,ge,1 ) +c gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) +c END IF + + 20 CONTINUE +c$OMP END DO + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 +#ifdef DEBUG_IO + CALL WriteField_u('du_bis',du) +#endif +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + du(ij,l)=du(ij,l)+du2(ij,l)-du1(ij,l) + ENDDO + + DO ij = ijb+iip1-1, ije, iip1 + du( ij, l ) = du( ij -iim, l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT +#ifdef DEBUG_IO + CALL WriteField_u('du1',du1) + CALL WriteField_u('du2',du2) + CALL WriteField_u('du_bis',du) +#endif + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + dv(ij,l)=dv(ij,l)+dv2(ij,l)-dv1(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + dteta(ij,l)=dteta(ij,l)+dteta2(ij,l)-dteta1(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/advect_new_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advect_new_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advect_new_mod.F90 (revision 1632) @@ -0,0 +1,55 @@ +MODULE advect_new_mod + + REAL,POINTER,SAVE :: dv1(:,:) + REAL,POINTER,SAVE :: du1(:,:) + REAL,POINTER,SAVE :: dteta1(:,:) + REAL,POINTER,SAVE :: dv2(:,:) + REAL,POINTER,SAVE :: du2(:,:) + REAL,POINTER,SAVE :: dteta2(:,:) + REAL,POINTER,SAVE :: uav(:,:) + REAL,POINTER,SAVE :: vav(:,:) + + +CONTAINS + + SUBROUTINE advect_new_allocate + USE bands + USE allocate_field + USE parallel + USE dimensions + IMPLICIT NONE + TYPE(distrib),POINTER :: d + + + d=>distrib_caldyn + CALL allocate_v(dv1,llm,d) + CALL allocate_u(du1,llm,d) + CALL allocate_u(dteta1,llm,d) + CALL allocate_v(dv2,llm,d) + CALL allocate_u(du2,llm,d) + CALL allocate_u(dteta2,llm,d) + CALL allocate_u(uav,llm,d) + CALL allocate_v(vav,llm,d) + + + END SUBROUTINE advect_new_allocate + + SUBROUTINE advect_new_switch_caldyn(dist) + USE allocate_field + USE bands + USE parallel + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_v(dv1,distrib_caldyn,dist) + CALL switch_u(du1,distrib_caldyn,dist) + CALL switch_u(dteta1,distrib_caldyn,dist) + CALL switch_v(dv2,distrib_caldyn,dist) + CALL switch_u(du2,distrib_caldyn,dist) + CALL switch_u(dteta2,distrib_caldyn,dist) + CALL switch_u(uav,distrib_caldyn,dist) + CALL switch_v(vav,distrib_caldyn,dist) + + END SUBROUTINE advect_new_switch_caldyn + +END MODULE advect_new_mod Index: /LMDZ5/trunk/libf/dyn3dmem/advect_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advect_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advect_p.F (revision 1632) @@ -0,0 +1,219 @@ +! +! $Header$ +! + SUBROUTINE advect_p(ucov,vcov,teta,w,massebx,masseby,du,dv,dteta) + USE parallel + USE write_field_p + IMPLICIT NONE +c======================================================================= +c +c Auteurs: P. Le Van , Fr. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ************************************************************* +c .... calcul des termes d'advection vertic.pour u,v,teta,q ... +c ************************************************************* +c ces termes sont ajoutes a du,dv,dteta et dq . +c Modif F.Forget 03/94 : on retire q de advect +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "ener.h" + +c Arguments: +c ---------- + + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),w(ip1jmp1,llm) + REAL dv(ip1jm,llm),du(ip1jmp1,llm),dteta(ip1jmp1,llm) + +c Local: +c ------ + + REAL uav(ip1jmp1,llm),vav(ip1jm,llm),wsur2(ip1jmp1) + REAL unsaire2(ip1jmp1), ge(ip1jmp1) + REAL deuxjour, ww, gt, uu, vv + + INTEGER ij,l,ijb,ije + + EXTERNAL SSUM + REAL SSUM + +c----------------------------------------------------------------------- +c 2. Calculs preliminaires: +c ------------------------- + + IF (conser) THEN + deuxjour = 2. * daysec + + DO 1 ij = 1, ip1jmp1 + unsaire2(ij) = unsaire(ij) * unsaire(ij) + 1 CONTINUE + END IF + + +c------------------ -yy ---------------------------------------------- +c . Calcul de u + + DO l=1,llm + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c DO ij = iip2, ip1jmp1 +c uav(ij,l) = 0.25 * ( ucov(ij,l) + ucov(ij-iip1,l) ) +c ENDDO + +c DO ij = iip2, ip1jm +c uav(ij,l) = uav(ij,l) + uav(ij+iip1,l) +c ENDDO + + DO ij = ijb, ije + + uav(ij,l)=0.25*(ucov(ij,l)+ucov(ij-iip1,l)) + . +0.25*(ucov(ij+iip1,l)+ucov(ij,l)) + ENDDO + + if (pole_nord) then + DO ij = 1, iip1 + uav(ij ,l) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iip1 + uav(ip1jm+ij,l) = 0. + ENDDO + endif + + ENDDO + +c call write_field3d_p('uav',reshape(uav,(/iip1,jjp1,llm/))) + +c------------------ -xx ---------------------------------------------- +c . Calcul de v + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO l=1,llm + + DO ij = ijb+1, ije + vav(ij,l) = 0.25 * ( vcov(ij,l) + vcov(ij-1,l) ) + ENDDO + + DO ij = ijb,ije,iip1 + vav(ij,l) = vav(ij+iim,l) + ENDDO + + + DO ij = ijb, ije-1 + vav(ij,l) = vav(ij,l) + vav(ij+1,l) + ENDDO + + DO ij = ijb, ije, iip1 + vav(ij+iim,l) = vav(ij,l) + ENDDO + + ENDDO +c call write_field3d_p('vav',reshape(vav,(/iip1,jjm,llm/))) +c----------------------------------------------------------------------- + + + + DO 20 l = 1, llmm1 + + +c ...... calcul de - w/2. au niveau l+1 ....... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO 5 ij = ijb, ije + wsur2( ij ) = - 0.5 * w( ij,l+1 ) + 5 CONTINUE + + +c ..................... calcul pour du .................. + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO 6 ij = ijb ,ije-1 + ww = wsur2 ( ij ) + wsur2( ij+1 ) + uu = 0.5 * ( ucov(ij,l) + ucov(ij,l+1) ) + du(ij,l) = du(ij,l) - ww * ( uu - uav(ij, l ) )/massebx(ij, l ) + du(ij,l+1)= du(ij,l+1) + ww * ( uu - uav(ij,l+1) )/massebx(ij,l+1) + 6 CONTINUE + +c ..... correction pour du(iip1,j,l) ........ +c ..... du(iip1,j,l)= du(1,j,l) ..... + +CDIR$ IVDEP + DO 7 ij = ijb+iip1-1, ije, iip1 + du( ij, l ) = du( ij -iim, l ) + du( ij,l+1 ) = du( ij -iim,l+1 ) + 7 CONTINUE + +c ................. calcul pour dv ..................... + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 8 ij = ijb, ije + ww = wsur2( ij+iip1 ) + wsur2( ij ) + vv = 0.5 * ( vcov(ij,l) + vcov(ij,l+1) ) + dv(ij,l) = dv(ij, l ) - ww * (vv - vav(ij, l ) )/masseby(ij, l ) + dv(ij,l+1)= dv(ij,l+1) + ww * (vv - vav(ij,l+1) )/masseby(ij,l+1) + 8 CONTINUE + +c + +c ............................................................ +c ............... calcul pour dh ................... +c ............................................................ + +c ---z +c calcul de - d( teta * w ) qu'on ajoute a dh +c ............... + ijb=ij_begin + ije=ij_end + + DO 15 ij = ijb, ije + ww = wsur2(ij) * (teta(ij,l) + teta(ij,l+1) ) + dteta(ij, l ) = dteta(ij, l ) - ww + dteta(ij,l+1) = dteta(ij,l+1) + ww + 15 CONTINUE + +c ym ---> conser a voir plus tard + +c IF( conser) THEN +c +c DO 17 ij = 1,ip1jmp1 +c ge(ij) = wsur2(ij) * wsur2(ij) * unsaire2(ij) +c 17 CONTINUE +c gt = SSUM( ip1jmp1,ge,1 ) +c gtot(l) = deuxjour * SQRT( gt/ip1jmp1 ) +c END IF + + 20 CONTINUE + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/advn.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advn.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advn.F (revision 1632) @@ -0,0 +1,983 @@ +! +! $Header$ +! + SUBROUTINE advn(q,masse,w,pbaru,pbarv,pdt,mode) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +#include "iniprint.h" + +c +c Arguments: +c ---------- + integer mode + real masse(ip1jmp1,llm) + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm) + REAL q(ip1jmp1,llm) + REAL w(ip1jmp1,llm),pdt +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii + integer ijlqmin,iqmin,jqmin,lqmin + integer ismin +c + real zm(ip1jmp1,llm),newmasse + real mu(ip1jmp1,llm) + real mv(ip1jm,llm) + real mw(ip1jmp1,llm+1) + real zq(ip1jmp1,llm),zz,qpn,qps + real zqg(ip1jmp1,llm),zqd(ip1jmp1,llm) + real zqs(ip1jmp1,llm),zqn(ip1jmp1,llm) + real zqh(ip1jmp1,llm),zqb(ip1jmp1,llm) + real temps0,temps1,temps2,temps3 + real ztemps1,ztemps2,ztemps3,ssum + logical testcpu + save testcpu + save temps1,temps2,temps3 + real zzpbar,zzw + +#ifdef CRAY + real second +#endif + + real qmin,qmax + data qmin,qmax/0.,1./ + data testcpu/.false./ + data temps1,temps2,temps3/0.,0.,0./ + + zzpbar = 0.5 * pdt + zzw = pdt + + DO l=1,llm + DO ij = iip2,ip1jm + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jm + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + DO ij=1,ip1jmp1 + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO + + DO ij=1,ip1jmp1 + mw(ij,llm+1)=0. + ENDDO + + do l=1,llm + qpn=0. + qps=0. + do ij=1,iim + qpn=qpn+q(ij,l)*masse(ij,l) + qps=qps+q(ip1jm+ij,l)*masse(ip1jm+ij,l) + enddo + qpn=qpn/ssum(iim,masse(1,l),1) + qps=qps/ssum(iim,masse(ip1jm+1,l),1) + do ij=1,iip1 + q(ij,l)=qpn + q(ip1jm+ij,l)=qps + enddo + enddo + + do ij=1,ip1jmp1 + mw(ij,llm+1)=0. + enddo + do l=1,llm + do ij=1,ip1jmp1 + zq(ij,l)=q(ij,l) + zm(ij,l)=masse(ij,l) + enddo + enddo + +c call minmaxq(zq,qmin,qmax,'avant vlx ') + call advnqx(zq,zqg,zqd) + call advnx(zq,zqg,zqd,zm,mu,mode) + call advnqy(zq,zqs,zqn) + call advny(zq,zqs,zqn,zm,mv) + call advnqz(zq,zqh,zqb) + call advnz(zq,zqh,zqb,zm,mw) +c call vlz(zq,0.,zm,mw) + call advnqy(zq,zqs,zqn) + call advny(zq,zqs,zqn,zm,mv) + call advnqx(zq,zqg,zqd) + call advnx(zq,zqg,zqd,zm,mu,mode) +c call minmaxq(zq,qmin,qmax,'apres vlx ') + +#ifdef CRAY + if(testcpu) then + ztemps1=second(0.) + temps1=temps1+ztemps1-ztemps2 + print*,'VLSPLT X:',temps1,' Y:',temps2,' Z:',temps3 + endif +#endif + do l=1,llm + do ij=1,ip1jmp1 + q(ij,l)=zq(ij,l) + enddo + do ij=1,ip1jm+1,iip1 + q(ij+iim,l)=q(ij,l) + enddo + enddo + + RETURN + END + + SUBROUTINE advnqx(q,qg,qd) +c +c Auteurs: Calcul des valeurs de q aux point u. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qg(ip1jmp1,llm),qd(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dxqu(ip1jmp1),zqu(ip1jmp1) + real zqmax(ip1jmp1),zqmin(ip1jmp1) + logical extremum(ip1jmp1) + + integer mode + save mode + data mode/1/ + +c calcul des pentes en u: +c ----------------------- + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jm + qd(ij,l)=q(ij,l) + qg(ij,l)=q(ij,l) + enddo + enddo + else + do l = 1, llm + do ij=iip2,ip1jm-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + zqu(ij)=0.5*(q(ij+1,l)+q(ij,l)) + enddo + do ij=iip1+iip1,ip1jm,iip1 + dxqu(ij)=dxqu(ij-iim) + zqu(ij)=zqu(ij-iim) + enddo + do ij=iip2,ip1jm-1 + zqu(ij)=zqu(ij)-dxqu(ij+1)/12. + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqu(ij)=zqu(ij-iim) + enddo + do ij=iip2+1,ip1jm + zqu(ij)=zqu(ij)+dxqu(ij-1)/12. + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqu(ij-iim)=zqu(ij) + enddo + +c calcul des valeurs max et min acceptees aux interfaces + + do ij=iip2,ip1jm-1 + zqmax(ij)=max(q(ij+1,l),q(ij,l)) + zqmin(ij)=min(q(ij+1,l),q(ij,l)) + enddo + do ij=iip1+iip1,ip1jm,iip1 + zqmax(ij)=zqmax(ij-iim) + zqmin(ij)=zqmin(ij-iim) + enddo + do ij=iip2+1,ip1jm + extremum(ij)=dxqu(ij)*dxqu(ij-1).le.0. + enddo + do ij=iip1+iip1,ip1jm,iip1 + extremum(ij-iim)=extremum(ij) + enddo + do ij=iip2,ip1jm + zqu(ij)=min(max(zqmin(ij),zqu(ij)),zqmax(ij)) + enddo + do ij=iip2+1,ip1jm + if(extremum(ij)) then + qg(ij,l)=q(ij,l) + qd(ij,l)=q(ij,l) + else + qd(ij,l)=zqu(ij) + qg(ij,l)=zqu(ij-1) + endif + enddo + do ij=iip1+iip1,ip1jm,iip1 + qd(ij-iim,l)=qd(ij,l) + qg(ij-iim,l)=qg(ij,l) + enddo + + goto 8888 + + do ij=iip2+1,ip1jm + if(extremum(ij).and..not.extremum(ij-1)) + s qd(ij-1,l)=q(ij,l) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + qd(ij-iim,l)=qd(ij,l) + enddo + do ij=iip2,ip1jm-1 + if (extremum(ij).and..not.extremum(ij+1)) + s qg(ij+1,l)=q(ij,l) + enddo + + do ij=iip1+iip1,ip1jm,iip1 + qg(ij,l)=qg(ij-iim,l) + enddo +8888 continue + enddo + endif + RETURN + END + SUBROUTINE advnqy(q,qs,qn) +c +c Auteurs: Calcul des valeurs de q aux point v. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qs(ip1jmp1,llm),qn(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dyqv(ip1jm),zqv(ip1jm,llm) + real zqmax(ip1jm),zqmin(ip1jm) + logical extremum(ip1jmp1) + + integer mode + save mode + data mode/1/ + + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jmp1 + qn(ij,l)=q(ij,l) + qs(ij,l)=q(ij,l) + enddo + enddo + else + +c calcul des pentes en u: +c ----------------------- + do l = 1, llm + do ij=1,ip1jm + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + enddo + + do ij=iip2,ip1jm-iip1 + zqv(ij,l)=0.5*(q(ij+iip1,l)+q(ij,l)) + zqv(ij,l)=zqv(ij,l)+(dyqv(ij+iip1)-dyqv(ij-iip1))/12. + enddo + + do ij=iip2,ip1jm + extremum(ij)=dyqv(ij)*dyqv(ij-iip1).le.0. + enddo + +c Pas de pentes aux poles + do ij=1,iip1 + zqv(ij,l)=q(ij,l) + zqv(ip1jm-iip1+ij,l)=q(ip1jm+ij,l) + extremum(ij)=.true. + extremum(ip1jmp1-iip1+ij)=.true. + enddo + +c calcul des valeurs max et min acceptees aux interfaces + do ij=1,ip1jm + zqmax(ij)=max(q(ij+iip1,l),q(ij,l)) + zqmin(ij)=min(q(ij+iip1,l),q(ij,l)) + enddo + + do ij=1,ip1jm + zqv(ij,l)=min(max(zqmin(ij),zqv(ij,l)),zqmax(ij)) + enddo + + do ij=iip2,ip1jm + if(extremum(ij)) then + qs(ij,l)=q(ij,l) + qn(ij,l)=q(ij,l) +c if (.not.extremum(ij-iip1)) qs(ij-iip1,l)=q(ij,l) +c if (.not.extremum(ij+iip1)) qn(ij+iip1,l)=q(ij,l) + else + qs(ij,l)=zqv(ij,l) + qn(ij,l)=zqv(ij-iip1,l) + endif + enddo + + do ij=1,iip1 + qs(ij,l)=q(ij,l) + qn(ij,l)=q(ij,l) + qs(ip1jm+ij,l)=q(ip1jm+ij,l) + qn(ip1jm+ij,l)=q(ip1jm+ij,l) + enddo + + enddo + endif + RETURN + END + + SUBROUTINE advnqz(q,qh,qb) +c +c Auteurs: Calcul des valeurs de q aux point v. +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real q(ip1jmp1,llm),qh(ip1jmp1,llm),qb(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real dzqw(ip1jmp1,llm+1),zqw(ip1jmp1,llm+1) + real zqmax(ip1jmp1,llm),zqmin(ip1jmp1,llm) + logical extremum(ip1jmp1,llm) + + integer mode + save mode + + data mode/1/ + +c calcul des pentes en u: +c ----------------------- + + if (mode.eq.0) then + do l=1,llm + do ij=1,ip1jmp1 + qb(ij,l)=q(ij,l) + qh(ij,l)=q(ij,l) + enddo + enddo + else + do l = 2, llm + do ij=1,ip1jmp1 + dzqw(ij,l)=q(ij,l-1)-q(ij,l) + zqw(ij,l)=0.5*(q(ij,l-1)+q(ij,l)) + enddo + enddo + do ij=1,ip1jmp1 + dzqw(ij,1)=0. + dzqw(ij,llm+1)=0. + enddo + do l=2,llm + do ij=1,ip1jmp1 + zqw(ij,l)=zqw(ij,l)+(dzqw(ij,l+1)-dzqw(ij,l-1))/12. + enddo + enddo + do l=2,llm-1 + do ij=1,ip1jmp1 + extremum(ij,l)=dzqw(ij,l)*dzqw(ij,l+1).le.0. + enddo + enddo + +c Pas de pentes en bas et en haut + do ij=1,ip1jmp1 + zqw(ij,2)=q(ij,1) + zqw(ij,llm)=q(ij,llm) + extremum(ij,1)=.true. + extremum(ij,llm)=.true. + enddo + +c calcul des valeurs max et min acceptees aux interfaces + do l=2,llm + do ij=1,ip1jmp1 + zqmax(ij,l)=max(q(ij,l-1),q(ij,l)) + zqmin(ij,l)=min(q(ij,l-1),q(ij,l)) + enddo + enddo + + do l=2,llm + do ij=1,ip1jmp1 + zqw(ij,l)=min(max(zqmin(ij,l),zqw(ij,l)),zqmax(ij,l)) + enddo + enddo + + do l=2,llm-1 + do ij=1,ip1jmp1 + if(extremum(ij,l)) then + qh(ij,l)=q(ij,l) + qb(ij,l)=q(ij,l) + else + qh(ij,l)=zqw(ij,l+1) + qb(ij,l)=zqw(ij,l) + endif + enddo + enddo +c do l=2,llm-1 +c do ij=1,ip1jmp1 +c if(extremum(ij,l)) then +c if (.not.extremum(ij,l-1)) qh(ij,l-1)=q(ij,l) +c if (.not.extremum(ij,l+1)) qb(ij,l+1)=q(ij,l) +c endif +c enddo +c enddo + + do ij=1,ip1jmp1 + qb(ij,1)=q(ij,1) + qh(ij,1)=q(ij,1) + qb(ij,llm)=q(ij,llm) + qh(ij,llm)=q(ij,llm) + enddo + + endif + + RETURN + END + + SUBROUTINE advnx(q,qg,qd,masse,u_m,mode) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + integer mode + real masse(ip1jmp1,llm) + real u_m( ip1jmp1,llm ) + real q(ip1jmp1,llm),qd(ip1jmp1,llm),qg(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER i,j,ij,l,indu(ip1jmp1),niju,iju,ijq + integer n0,nl(llm) +c + real new_m,zu_m,zdq,zz + real zsigg(ip1jmp1,llm),zsigd(ip1jmp1,llm),zsig + real u_mq(ip1jmp1,llm) + + real zm,zq,zsigm,zsigp,zqm,zqp,zu + + logical ladvplus(ip1jmp1,llm) + + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-15/ +#endif + + do l=1,llm + do ij=iip2,ip1jm + zdq=qd(ij,l)-qg(ij,l) +c if((qd(ij,l)-q(ij,l))*(q(ij,l)-qg(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,qd(ij,l),q(ij,l),qg(ij,l) +c qd(ij,l)=q(ij,l) +c qg(ij,l)=q(ij,l) +c endif + if(abs(zdq).gt.prec) then + zsigd(ij,l)=(q(ij,l)-qg(ij,l))/zdq + zsigg(ij,l)=1.-zsigd(ij,l) +c if(.not.(zsigd(ij,l).ge.0..and.zsigd(ij,l).le.1. .and. +c s zsigg(ij,l).ge.0..or.zsigg(ij,l).le.1.) ) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,'sigg=',zsigg(ij,l),' sigd=',zsigd(ij,l) +c print*,'q d,c,g ',qd(ij,l),q(ij,l),qg(ij,l),zdq +c stop +c endif + else + zsigd(ij,l)=0.5 + zsigg(ij,l)=0.5 + qd(ij,l)=q(ij,l) + qg(ij,l)=q(ij,l) + endif + enddo + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do l=1,llm + do ij=iip2,ip1jm-1 + if (u_m(ij,l).ge.0.) then + zsigp=zsigd(ij,l) + zsigm=zsigg(ij,l) + zqp=qd(ij,l) + zqm=qg(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + else + zsigm=zsigd(ij+1,l) + zsigp=zsigg(ij+1,l) + zqm=qd(ij+1,l) + zqp=qg(ij+1,l) + zm=masse(ij+1,l) + zq=q(ij+1,l) + endif + zu=abs(u_m(ij,l)) + ladvplus(ij,l)=zu.gt.zm + zsig=zu/zm + if(zsig.eq.0.) zsigp=0.1 + if (mode.eq.1) then + if (zsig.le.zsigp) then + u_mq(ij,l)=u_m(ij,l)*zqp + else if (mode.eq.1) then + u_mq(ij,l)= + s sign(zm,u_m(ij,l))*(zsigp*zqp+(zsig-zsigp)*zqm) + endif + else + if (zsig.le.zsigp) then + u_mq(ij,l)=u_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + u_mq(ij,l)=sign(zm,u_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + endif +c if(zsig.lt.0.) then +c print*,'au point ij=',ij,' l=',l,' sig=',zsig +c stop +c endif + enddo + enddo + + do l=1,llm + do ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ladvplus(ij,l)=ladvplus(ij-iim,l) + enddo + enddo + +c================================================================= +C SCHEMA SEMI-LAGRAGIEN EN X DANS LES REGIONS POLAIRES +c================================================================= +c tris des regions a traiter + n0=0 + do l=1,llm + nl(l)=0 + do ij=iip2,ip1jm + if(ladvplus(ij,l)) then + nl(l)=nl(l)+1 + u_mq(ij,l)=0. + endif + enddo + n0=n0+nl(l) + enddo + + if(n0.gt.1) then + IF (prt_level > 9) WRITE(lunout,*) + & 'Nombre de points pour lesquels on advect plus que le' + & ,'contenu de la maille : ',n0 + + do l=1,llm + if(nl(l).gt.0) then + iju=0 +c indicage des mailles concernees par le traitement special + do ij=iip2,ip1jm + if(ladvplus(ij,l).and.mod(ij,iip1).ne.0) then + iju=iju+1 + indu(iju)=ij + endif + enddo + niju=iju +c print*,'niju,nl',niju,nl(l) + +c traitement des mailles + do iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + if(zu_m.gt.0.) then + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + enddo +c MODIFS SPECIFIQUES DU SCHEMA +c ajout de la maille non completement advectee + zsig=zu_m/masse(ijq,l) + if(zsig.le.zsigd(ijq,l)) then + u_mq(ij,l)=u_mq(ij,l)+zu_m*(qd(ijq,l) + s -0.5*zsig/zsigd(ijq,l)*(qd(ijq,l)-q(ijq,l))) + else +c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) +c goto 8888 + zz=0.5*(zsig-zsigd(ijq,l))/zsigg(ijq,l) + if(.not.(zz.gt.0..and.zz.le.0.5)) then + WRITE(lunout,*)'probleme2 au point ij=',ij, + s ' l=',l + WRITE(lunout,*)'zz=',zz + stop + endif + u_mq(ij,l)=u_mq(ij,l)+masse(ijq,l)*( + s 0.5*(q(ijq,l)+qd(ijq,l))*zsigd(ijq,l) + s +(zsig-zsigd(ijq,l))*(q(ijq,l)+zz*(qg(ijq,l)-q(ijq,l))) ) + endif + else + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + enddo +c ajout de la maille non completement advectee +c 2eme MODIF SPECIFIQUE + zsig=-zu_m/masse(ij+1,l) + if(zsig.le.zsigg(ijq,l)) then + u_mq(ij,l)=u_mq(ij,l)+zu_m*(qg(ijq,l) + s -0.5*zsig/zsigg(ijq,l)*(qg(ijq,l)-q(ijq,l))) + else +c u_mq(ij,l)=u_mq(ij,l)+zu_m*q(ijq,l) +c goto 9999 + zz=0.5*(zsig-zsigg(ijq,l))/zsigd(ijq,l) + if(.not.(zz.gt.0..and.zz.le.0.5)) then + WRITE(lunout,*)'probleme22 au point ij=',ij + s ,' l=',l + WRITE(lunout,*)'zz=',zz + stop + endif + u_mq(ij,l)=u_mq(ij,l)-masse(ijq,l)*( + s 0.5*(q(ijq,l)+qg(ijq,l))*zsigg(ijq,l) + s +(zsig-zsigg(ijq,l))* + s (q(ijq,l)+zz*(qd(ijq,l)-q(ijq,l))) ) + endif +c fin de la modif + endif + enddo + endif + enddo + endif ! n0.gt.0 + +c bouclage en latitude + do l=1,llm + do ij=iip1+iip1,ip1jm,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + enddo + enddo + +c================================================================= +c CALCUL DE LA CONVERGENCE DES FLUX +c================================================================= + + do l=1,llm + do ij=iip2+1,ip1jm + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + enddo +c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + do ij=iip1+iip1,ip1jm,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + enddo + enddo + + RETURN + END + SUBROUTINE advny(q,qs,qn,masse,v_m) +c +c Auteur : F. Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real masse(ip1jmp1,llm) + real v_m( ip1jm,llm ) + real q(ip1jmp1,llm),qn(ip1jmp1,llm),qs(ip1jmp1,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + real new_m,zdq,zz + real zsigs(ip1jmp1),zsign(ip1jmp1),zsig + real v_mq(ip1jm,llm) + real convpn,convps,convmpn,convmps,massen,masses + real zm,zq,zsigm,zsigp,zqm,zqp + real ssum + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-15/ +#endif + do l=1,llm + do ij=1,ip1jmp1 + zdq=qn(ij,l)-qs(ij,l) +c if((qn(ij,l)-q(ij,l))*(q(ij,l)-qs(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l,' advnqx' +c print*,qn(ij,l),q(ij,l),qs(ij,l) +c qn(ij,l)=q(ij,l) +c qs(ij,l)=q(ij,l) +c endif + if(abs(zdq).gt.prec) then + zsign(ij)=(q(ij,l)-qs(ij,l))/zdq + zsigs(ij)=1.-zsign(ij) +c if(.not.(zsign(ij).ge.0..and.zsign(ij).le.1. .and. +c s zsigs(ij).ge.0..or.zsigs(ij).le.1.) ) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,'sigs=',zsigs(ij),' sign=',zsign(ij) +c stop +c endif + else + zsign(ij)=0.5 + zsigs(ij)=0.5 + endif + enddo + +c calcul de la pente maximum dans la maille en valeur absolue + + do ij=1,ip1jm + if (v_m(ij,l).ge.0.) then + zsigp=zsign(ij+iip1) + zsigm=zsigs(ij+iip1) + zqp=qn(ij+iip1,l) + zqm=qs(ij+iip1,l) + zm=masse(ij+iip1,l) + zq=q(ij+iip1,l) + else + zsigm=zsign(ij) + zsigp=zsigs(ij) + zqm=qn(ij,l) + zqp=qs(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + endif + zsig=abs(v_m(ij,l))/zm + if(zsig.eq.0.) zsigp=0.1 + if (zsig.le.zsigp) then + v_mq(ij,l)=v_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + v_mq(ij,l)=sign(zm,v_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + enddo + enddo + + do l=1,llm + do ij=iip2,ip1jm + new_m=masse(ij,l) + & +v_m(ij,l)-v_m(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+v_mq(ij,l)-v_mq(ij-iip1,l)) + & /new_m + masse(ij,l)=new_m + enddo +c.-. ancienne version + convpn=SSUM(iim,v_mq(1,l),1) + convmpn=ssum(iim,v_m(1,l),1) + massen=ssum(iim,masse(1,l),1) + new_m=massen+convmpn + q(1,l)=(q(1,l)*massen+convpn)/new_m + do ij = 1,iip1 + q(ij,l)=q(1,l) + masse(ij,l)=new_m*aire(ij)/apoln + enddo + + convps=-SSUM(iim,v_mq(ip1jm-iim,l),1) + convmps=-ssum(iim,v_m(ip1jm-iim,l),1) + masses=ssum(iim,masse(ip1jm+1,l),1) + new_m=masses+convmps + q(ip1jm+1,l)=(q(ip1jm+1,l)*masses+convps)/new_m + do ij = ip1jm+1,ip1jmp1 + q(ij,l)=q(ip1jm+1,l) + masse(ij,l)=new_m*aire(ij)/apols + enddo + enddo + + RETURN + END + SUBROUTINE advnz(q,qh,qb,masse,w_m) +c +c Auteurs: F.Hourdin +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c b designe le bas et h le haut +c il y a une correspondance entre le b en z et le d en x +c ******************************************************************** +c +c +c -------------------------------------------------------------------- + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "iniprint.h" +c +c +c Arguments: +c ---------- + real masse(ip1jmp1,llm) + real w_m( ip1jmp1,llm+1) + real q(ip1jmp1,llm),qb(ip1jmp1,llm),qh(ip1jmp1,llm) + +c +c Local +c --------- +c + INTEGER ij,l +c + real new_m,zdq,zz + real zsigh(ip1jmp1,llm),zsigb(ip1jmp1,llm),zsig + real w_mq(ip1jmp1,llm+1) + real zm,zq,zsigm,zsigp,zqm,zqp + real prec + save prec + +#ifdef CRAY + data prec/1.e-24/ +#else + data prec/1.e-13/ +#endif + + do l=1,llm + do ij=1,ip1jmp1 + zdq=qb(ij,l)-qh(ij,l) +c if((qh(ij,l)-q(ij,l))*(q(ij,l)-qb(ij,l)).lt.0.) then +c print*,'probleme au point ij=',ij,' l=',l +c print*,qh(ij,l),q(ij,l),qb(ij,l) +c qh(ij,l)=q(ij,l) +c qb(ij,l)=q(ij,l) +c endif + + if(abs(zdq).gt.prec) then + zsigb(ij,l)=(q(ij,l)-qh(ij,l))/zdq + zsigh(ij,l)=1.-zsigb(ij,l) + zsigb(ij,l)=min(max(zsigb(ij,l),0.),1.) + else + zsigb(ij,l)=0.5 + zsigh(ij,l)=0.5 + endif + enddo + enddo + +c print*,'ok1' +c calcul de la pente maximum dans la maille en valeur absolue + do l=2,llm + do ij=1,ip1jmp1 + if (w_m(ij,l).ge.0.) then + zsigp=zsigb(ij,l) + zsigm=zsigh(ij,l) + zqp=qb(ij,l) + zqm=qh(ij,l) + zm=masse(ij,l) + zq=q(ij,l) + else + zsigm=zsigb(ij,l-1) + zsigp=zsigh(ij,l-1) + zqm=qb(ij,l-1) + zqp=qh(ij,l-1) + zm=masse(ij,l-1) + zq=q(ij,l-1) + endif + zsig=abs(w_m(ij,l))/zm + if(zsig.eq.0.) zsigp=0.1 + if (zsig.le.zsigp) then + w_mq(ij,l)=w_m(ij,l)*(zqp-0.5*zsig/zsigp*(zqp-zq)) + else + zz=0.5*(zsig-zsigp)/zsigm + w_mq(ij,l)=sign(zm,w_m(ij,l))*( 0.5*(zq+zqp)*zsigp + s +(zsig-zsigp)*(zq+zz*(zqm-zq)) ) + endif + enddo + enddo + + do ij=1,ip1jmp1 + w_mq(ij,llm+1)=0. + w_mq(ij,1)=0. + enddo + + do l=1,llm + do ij=1,ip1jmp1 + new_m=masse(ij,l)+w_m(ij,l+1)-w_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+w_mq(ij,l+1)-w_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + enddo + enddo +c print*,'ok3' + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/advtrac_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advtrac_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advtrac_loc.F (revision 1632) @@ -0,0 +1,360 @@ +! +! $Id: advtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c +c +#define DEBUG_IO +#undef DEBUG_IO + SUBROUTINE advtrac_loc(pbarug,pbarvg ,wg, + * p, massem,q,teta, + * pk ) + +c Auteur : F. Hourdin +c +c Modif. P. Le Van (20/12/97) +c F. Codron (10/99) +c D. Le Croller (07/2001) +c M.A Filiberti (04/2002) +c + USE parallel + USE Write_Field_loc + USE Write_Field + USE Bands + USE mod_hallo + USE Vampir + USE times + USE infotrac + USE control_mod + USE advtrac_mod + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comdissip.h" +#include "comgeom2.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" + +c------------------------------------------------------------------- +c Arguments +c------------------------------------------------------------------- +c Ajout PPM +c-------------------------------------------------------- + REAL massebx(ijb_u:ije_u,llm),masseby(ijb_v:ije_v,llm) +c-------------------------------------------------------- + INTEGER iapptrac + REAL pbarug(ijb_u:ije_u,llm),pbarvg(ijb_v:ije_v,llm) + REAL wg(ijb_u:ije_u,llm) + REAL q(ijb_u:ije_u,llm,nqtot),massem(ijb_u:ije_u,llm) + REAL p( ijb_u:ije_u,llmp1 ),teta(ijb_u:ije_u,llm) + REAL pk(ijb_u:ije_u,llm) + +c------------------------------------------------------------- +c Variables locales +c------------------------------------------------------------- + + REAL zdp(ijb_u:ije_u) + REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu + INTEGER,SAVE :: iadvtr=0 +c$OMP THREADPRIVATE(iadvtr) + INTEGER ij,l,iq,iiq + REAL zdpmin, zdpmax +c---------------------------------------------------------- +c Rajouts pour PPM +c---------------------------------------------------------- + INTEGER indice,n + REAL dtbon ! Pas de temps adaptatif pour que CFL<1 + REAL CFLmaxz,aaa,bbb ! CFL maximum + REAL psppm(iim,jjb_u:jje_u) ! pression au sol + REAL unatppm(iim,jjb_u:jje_u,llm),vnatppm(iim,jjb_u:jje_u,llm) + REAL qppm(iim*jjnb_u,llm,nqtot) + REAL fluxwppm(iim,jjb_u:jje_u,llm) + REAL apppm(llmp1), bpppm(llmp1) + LOGICAL dum,fill + DATA fill/.true./ + DATA dum/.true./ + integer ijb,ije,ijbu,ijbv,ijeu,ijev,j + type(Request) :: testRequest + +c test sur l'eventuelle creation de valeurs negatives de la masse + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm-1 + DO ij = ijb+1,ije + zdp(ij) = pbarug(ij-1,l) - pbarug(ij,l) + s - pbarvg(ij-iip1,l) + pbarvg(ij,l) + s + wg(ij,l+1) - wg(ij,l) + ENDDO + +c CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 ) +c ym ---> pourquoi jjm-1 et non jjm ? a cause du pole ? + + do ij=ijb,ije-iip1+1,iip1 + zdp(ij)=zdp(ij+iip1-1) + enddo + + DO ij = ijb,ije + zdp(ij)= zdp(ij)*dtvr/ massem(ij,l) + ENDDO + + +c CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax ) +c ym ---> eventuellement a revoir + CALL minmax ( ije-ijb+1, zdp(ijb), zdpmin,zdpmax ) + + IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN + PRINT*,'WARNING DP/P l=',l,' MIN:',zdpmin, + s ' MAX:', zdpmax + ENDIF + + ENDDO +c$OMP END DO NOWAIT + +c------------------------------------------------------------------- +c Advection proprement dite (Modification Le Croller (07/2001) +c------------------------------------------------------------------- + +c---------------------------------------------------- +c Calcul des moyennes basées sur la masse +c---------------------------------------------------- + +cym ----> Normalement, inutile pour les schémas classiques +cym ----> Revérifier lors de la parallélisation des autres schemas + +cym call massbar_p(massem,massebx,masseby) + +#ifdef DEBUG_IO + CALL WriteField_u('massem',massem) + CALL WriteField_u('wg',wg) + CALL WriteField_u('pbarug',pbarug) + CALL WriteField_v('pbarvg',pbarvg) + CALL WriteField_u('p_tmp',p) + CALL WriteField_u('pk_tmp',pk) + CALL WriteField_u('teta_tmp',teta) + do j=1,nqtot + call WriteField_u('q_adv'//trim(int2str(j)), + . q(:,:,j)) + enddo +#endif + +! +! call Register_Hallo_v(pbarvg,llm,1,1,1,1,TestRequest) +! +! call SendRequest(TestRequest) +!c$OMP BARRIER +! call WaitRequest(TestRequest) +c$OMP BARRIER + + call vlspltgen_loc( q,iadv, 2., massem, wg , + * pbarug,pbarvg,dtvr,p, + * pk,teta ) + +#ifdef DEBUG_IO + do j=1,nqtot + call WriteField_u('q_adv'//trim(int2str(j)), + . q(:,:,j)) + enddo +#endif + + GOTO 1234 +c----------------------------------------------------------- +c Appel des sous programmes d'advection +c----------------------------------------------------------- + do iq=1,nqtot +c call clock(t_initial) + if(iadv(iq) == 0) cycle +c ---------------------------------------------------------------- +c Schema de Van Leer I MUSCL +c ---------------------------------------------------------------- + if(iadv(iq).eq.10) THEN + +!LF call vlsplt_p(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr) + +c ---------------------------------------------------------------- +c Schema "pseudo amont" + test sur humidite specifique +C pour la vapeur d'eau. F. Codron +c ---------------------------------------------------------------- + else if(iadv(iq).eq.14) then +c +cym stop 'advtrac : appel à vlspltqs :schema non parallelise' +!LF CALL vlspltqs_p( q(1,1,1), 2., massem, wg , +!LF * pbarug,pbarvg,dtvr,p,pk,teta ) +c ---------------------------------------------------------------- +c Schema de Frederic Hourdin +c ---------------------------------------------------------------- + else if(iadv(iq).eq.12) then + stop 'advtrac : schema non parallelise' +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif + do indice=1,n + call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1) + end do + else if(iadv(iq).eq.13) then + stop 'advtrac : schema non parallelise' +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif + do indice=1,n + call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2) + end do +c ---------------------------------------------------------------- +c Schema de pente SLOPES +c ---------------------------------------------------------------- + else if (iadv(iq).eq.20) then + stop 'advtrac : schema non parallelise' + + call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0) + +c ---------------------------------------------------------------- +c Schema de Prather +c ---------------------------------------------------------------- + else if (iadv(iq).eq.30) then + stop 'advtrac : schema non parallelise' +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif + call prather(q(1,1,iq),wg,massem,pbarug,pbarvg, + s n,dtbon) +c ---------------------------------------------------------------- +c Schemas PPM Lin et Rood +c ---------------------------------------------------------------- + else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND. + s iadv(iq).LE.18)) then + + stop 'advtrac : schema non parallelise' + +c Test sur le flux horizontal +c Pas de temps adaptatif + call adaptdt(iadv(iq),dtbon,n,pbarug,massem) + if (n.GT.1) then + write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', + s dtvr,'n=',n + endif +c Test sur le flux vertical + CFLmaxz=0. + do l=2,llm + do ij=iip2,ip1jm + aaa=wg(ij,l)*dtvr/massem(ij,l) + CFLmaxz=max(CFLmaxz,aaa) + bbb=-wg(ij,l)*dtvr/massem(ij,l-1) + CFLmaxz=max(CFLmaxz,bbb) + enddo + enddo + if (CFLmaxz.GE.1) then + write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz + endif + +c----------------------------------------------------------- +c Ss-prg interface LMDZ.4->PPM3d +c----------------------------------------------------------- + + call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, + s apppm,bpppm,massebx,masseby,pbarug,pbarvg, + s unatppm,vnatppm,psppm) + + do indice=1,n +c--------------------------------------------------------------------- +c VL (version PPM) horiz. et PPM vert. +c--------------------------------------------------------------------- + if (iadv(iq).eq.11) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) + +c---------------------------------------------------------------------- +c Monotonic PPM +c---------------------------------------------------------------------- + else if (iadv(iq).eq.16) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) +c--------------------------------------------------------------------- + +c--------------------------------------------------------------------- +c Semi Monotonic PPM +c--------------------------------------------------------------------- + else if (iadv(iq).eq.17) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) +c--------------------------------------------------------------------- + +c--------------------------------------------------------------------- +c Positive Definite PPM +c--------------------------------------------------------------------- + else if (iadv(iq).eq.18) then +c Ss-prg PPM3d de Lin + call ppm3d(1,qppm(1,1,iq), + s psppm,psppm, + s unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1, + s iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, + s fill,dum,220.) +c--------------------------------------------------------------------- + endif + enddo +c----------------------------------------------------------------- +c Ss-prg interface PPM3d-LMDZ.4 +c----------------------------------------------------------------- + call interpost(q(1,1,iq),qppm(1,1,iq)) + endif +c---------------------------------------------------------------------- + +c----------------------------------------------------------------- +c On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1 +c et Nord j=1 +c----------------------------------------------------------------- + +c call traceurpole(q(1,1,iq),massem) + +c calcul du temps cpu pour un schema donne + + + end DO + +1234 CONTINUE +c$OMP BARRIER + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + finmasse(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO +c$OMP END DO + + CALL qminimum_loc( q, 2, finmasse ) + + + RETURN + END + Index: /LMDZ5/trunk/libf/dyn3dmem/advtrac_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advtrac_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advtrac_mod.F90 (revision 1632) @@ -0,0 +1,37 @@ +MODULE advtrac_mod + + REAL,POINTER,SAVE :: finmasse(:,:) + +CONTAINS + + SUBROUTINE advtrac_allocate + USE bands + USE allocate_field + USE parallel + USE infotrac + USE vlspltgen_mod + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + TYPE(distrib),POINTER :: d + + d=>distrib_vanleer + CALL allocate_u(finmasse,llm,d) + CALL vlspltgen_allocate + END SUBROUTINE advtrac_allocate + + SUBROUTINE advtrac_switch_vanleer(dist) + USE allocate_field + USE bands + USE parallel + USE vlspltgen_mod + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(finmasse,distrib_vanleer,dist) + + CALL vlspltgen_switch_vanleer(dist) + + END SUBROUTINE advtrac_switch_vanleer + +END MODULE advtrac_mod Index: /LMDZ5/trunk/libf/dyn3dmem/advx.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advx.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advx.F (revision 1632) @@ -0,0 +1,497 @@ +! +! $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 + 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 + 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/dyn3dmem/advxp.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advxp.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advxp.F (revision 1632) @@ -0,0 +1,650 @@ +! +! $Header$ +! + SUBROUTINE ADVXP(LIMIT,DTX,PBARU,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra) + IMPLICIT NONE +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in X direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" + + INTEGER ntra +c PARAMETER (ntra = 1) +C +C definition de la grille du modele +C + REAL dtx + REAL pbaru ( iip1,jjp1,llm ) +C +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C Sij 2nd order moment in i and j directions +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + REAL SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL UGRI(iip1,jjp1,llm) + +C Rem : VGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en x uniquement ) +C +C +C Tij are the moments for the current latitude and level +C + REAL TM (iim) + REAL T0 (iim,NTRA),TX (iim,NTRA) + REAL TY (iim,NTRA),TZ (iim,NTRA) + REAL TXX(iim,NTRA),TXY(iim,NTRA) + REAL TXZ(iim,NTRA),TYY(iim,NTRA) + REAL TYZ(iim,NTRA),TZZ(iim,NTRA) +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL FM (iim) + REAL F0 (iim,NTRA),FX (iim,NTRA) + REAL FY (iim,NTRA),FZ (iim,NTRA) + REAL FXX(iim,NTRA),FXY(iim,NTRA) + REAL FXZ(iim,NTRA),FYY(iim,NTRA) + REAL FYZ(iim,NTRA),FZZ(iim,NTRA) +C +C work arrays +C + REAL ALF (iim),ALF1(iim),ALFQ(iim),ALF1Q(iim) + REAL ALF2(iim),ALF3(iim),ALF4(iim) +C + REAL SMNEW(iim),UEXT(iim) + REAL sqi,sqf + REAL TEMPTM + REAL SLPMAX + REAL S1MAX,S1NEW,S2NEW + + LOGICAL LIMIT + INTEGER NUM(jjp1),LONK,NUMK + INTEGER lon,lati,latf,niv + INTEGER i,i2,i3,j,jv,l,k,iter + + lon = iim + lati=2 + latf = jjm + niv = llm + +C *** Test de passage d'arguments ****** + +c DO 399 l = 1, llm +c DO 399 j = 1, jjp1 +c DO 399 i = 1, iip1 +c IF (S0(i,j,l,ntra) .lt. 0. ) THEN +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) +c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) +c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) +c PRINT*, 'AIE !! debut ADVXP - pbl arg. passage dans ADVXP' +cc STOP +c ENDIF +c 399 CONTINUE + +C *** Test : diagnostique de la qtite totale de traceur +C dans l'atmosphere avant l'advection +c + sqi =0. + sqf =0. +c + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'------ DIAG DANS ADVX2 - ENTREE -----' + PRINT*,'sqi=',sqi +c test +c ------------------------------------- + DO 300 j =1,jjp1 + NUM(j) =1 + 300 CONTINUE +c DO l=1,llm +c NUM(2,l)=6 +c NUM(3,l)=6 +c NUM(jjm-1,l)=6 +c NUM(jjm,l)=6 +c ENDDO +c DO j=2,6 +c NUM(j)=12 +c ENDDO +c DO j=jjm-5,jjm-1 +c NUM(j)=12 +c ENDDO + +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C --------------------------------------------------------- +C Conversion des flux de masses en kg/s +C pbaru est en N/s d'ou : +C ugri est en kg/s + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 + ugri (i,j,llm+1-l) =pbaru (i,j,l) + 500 CONTINUE + +C --------------------------------------------------------- +C start here +C +C boucle principale sur les niveaux et les latitudes +C + DO 1 L=1,NIV + DO 1 K=lati,latf + +C +C initialisation +C +C program assumes periodic boundaries in X +C + DO 10 I=2,LON + SMNEW(I)=SM(I,K,L)+(UGRI(I-1,K,L)-UGRI(I,K,L))*DTX + 10 CONTINUE + SMNEW(1)=SM(1,K,L)+(UGRI(LON,K,L)-UGRI(1,K,L))*DTX +C +C modifications for extended polar zones +C + NUMK=NUM(K) + LONK=LON/NUMK +C + IF(NUMK.GT.1) THEN +C + DO 111 I=1,LON + TM(I)=0. + 111 CONTINUE + DO 112 JV=1,NTRA + DO 1120 I=1,LON + T0 (I,JV)=0. + TX (I,JV)=0. + TY (I,JV)=0. + TZ (I,JV)=0. + TXX(I,JV)=0. + TXY(I,JV)=0. + TXZ(I,JV)=0. + TYY(I,JV)=0. + TYZ(I,JV)=0. + TZZ(I,JV)=0. + 1120 CONTINUE + 112 CONTINUE +C + DO 11 I2=1,NUMK +C + DO 113 I=1,LONK + I3=(I-1)*NUMK+I2 + TM(I)=TM(I)+SM(I3,K,L) + ALF(I)=SM(I3,K,L)/TM(I) + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALF1(I) + 113 CONTINUE +C + DO 114 JV=1,NTRA + DO 1140 I=1,LONK + I3=(I-1)*NUMK+I2 + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*S0(I3,K,L,JV) + T0 (I,JV)=T0(I,JV)+S0(I3,K,L,JV) + TXX(I,JV)=ALFQ(I)*SSXX(I3,K,L,JV)+ALF1Q(I)*TXX(I,JV) + + +5.*( ALF3(I)*(SSX(I3,K,L,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) + TX (I,JV)=ALF(I)*SSX(I3,K,L,JV)+ALF1(I)*TX(I,JV)+3.*TEMPTM + TXY(I,JV)=ALF (I)*SSXY(I3,K,L,JV)+ALF1(I)*TXY(I,JV) + + +3.*(ALF1(I)*SY (I3,K,L,JV)-ALF (I)*TY (I,JV)) + TXZ(I,JV)=ALF (I)*SSXZ(I3,K,L,JV)+ALF1(I)*TXZ(I,JV) + + +3.*(ALF1(I)*SZ (I3,K,L,JV)-ALF (I)*TZ (I,JV)) + TY (I,JV)=TY (I,JV)+SY (I3,K,L,JV) + TZ (I,JV)=TZ (I,JV)+SZ (I3,K,L,JV) + TYY(I,JV)=TYY(I,JV)+SYY(I3,K,L,JV) + TYZ(I,JV)=TYZ(I,JV)+SYZ(I3,K,L,JV) + TZZ(I,JV)=TZZ(I,JV)+SZZ(I3,K,L,JV) + 1140 CONTINUE + 114 CONTINUE +C + 11 CONTINUE +C + ELSE +C + DO 115 I=1,LON + TM(I)=SM(I,K,L) + 115 CONTINUE + DO 116 JV=1,NTRA + DO 1160 I=1,LON + T0 (I,JV)=S0 (I,K,L,JV) + TX (I,JV)=SSX (I,K,L,JV) + TY (I,JV)=SY (I,K,L,JV) + TZ (I,JV)=SZ (I,K,L,JV) + TXX(I,JV)=SSXX(I,K,L,JV) + TXY(I,JV)=SSXY(I,K,L,JV) + TXZ(I,JV)=SSXZ(I,K,L,JV) + TYY(I,JV)=SYY(I,K,L,JV) + TYZ(I,JV)=SYZ(I,K,L,JV) + TZZ(I,JV)=SZZ(I,K,L,JV) + 1160 CONTINUE + 116 CONTINUE +C + ENDIF +C + DO 117 I=1,LONK + UEXT(I)=UGRI(I*NUMK,K,L) + 117 CONTINUE +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 13 +C + DO 12 JV=1,NTRA + DO 120 I=1,LONK + IF(T0(I,JV).GT.0.) THEN + SLPMAX=T0(I,JV) + S1MAX=1.5*SLPMAX + S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,TX(I,JV))) + S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,TXX(I,JV)) ) + TX (I,JV)=S1NEW + TXX(I,JV)=S2NEW + TXY(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXY(I,JV))) + TXZ(I,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,TXZ(I,JV))) + ELSE + TX (I,JV)=0. + TXX(I,JV)=0. + TXY(I,JV)=0. + TXZ(I,JV)=0. + ENDIF + 120 CONTINUE + 12 CONTINUE +C + 13 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from IP to I if U(I).lt.0 +C + DO 140 I=1,LONK-1 + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(I+1) + TM(I+1)=TM(I+1)-FM(I) + ENDIF + 140 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN + FM(I)=-UEXT(I)*DTX + ALF(I)=FM(I)/TM(1) + TM(1)=TM(1)-FM(I) + ENDIF +C +C flux from I to IP if U(I).gt.0 +C + DO 141 I=1,LONK + IF(UEXT(I).GE.0.) THEN + FM(I)=UEXT(I)*DTX + ALF(I)=FM(I)/TM(I) + TM(I)=TM(I)-FM(I) + ENDIF + 141 CONTINUE +C + DO 142 I=1,LONK + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALFQ(I) + ALF4(I)=ALF1(I)*ALF1Q(I) + 142 CONTINUE +C + DO 150 JV=1,NTRA + DO 1500 I=1,LONK-1 +C + IF(UEXT(I).LT.0.) THEN +C + F0 (I,JV)=ALF (I)* ( T0(I+1,JV)-ALF1(I)* + + ( TX(I+1,JV)-ALF2(I)*TXX(I+1,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(I+1,JV)-3.*ALF1(I)*TXX(I+1,JV)) + FXX(I,JV)=ALF3(I)*TXX(I+1,JV) + FY (I,JV)=ALF (I)*(TY(I+1,JV)-ALF1(I)*TXY(I+1,JV)) + FZ (I,JV)=ALF (I)*(TZ(I+1,JV)-ALF1(I)*TXZ(I+1,JV)) + FXY(I,JV)=ALFQ(I)*TXY(I+1,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(I+1,JV) + FYY(I,JV)=ALF (I)*TYY(I+1,JV) + FYZ(I,JV)=ALF (I)*TYZ(I+1,JV) + FZZ(I,JV)=ALF (I)*TZZ(I+1,JV) +C + T0 (I+1,JV)=T0(I+1,JV)-F0(I,JV) + TX (I+1,JV)=ALF1Q(I)*(TX(I+1,JV)+3.*ALF(I)*TXX(I+1,JV)) + TXX(I+1,JV)=ALF4(I)*TXX(I+1,JV) + TY (I+1,JV)=TY (I+1,JV)-FY (I,JV) + TZ (I+1,JV)=TZ (I+1,JV)-FZ (I,JV) + TYY(I+1,JV)=TYY(I+1,JV)-FYY(I,JV) + TYZ(I+1,JV)=TYZ(I+1,JV)-FYZ(I,JV) + TZZ(I+1,JV)=TZZ(I+1,JV)-FZZ(I,JV) + TXY(I+1,JV)=ALF1Q(I)*TXY(I+1,JV) + TXZ(I+1,JV)=ALF1Q(I)*TXZ(I+1,JV) +C + ENDIF +C + 1500 CONTINUE + 150 CONTINUE +C + I=LONK + IF(UEXT(I).LT.0.) THEN +C + DO 151 JV=1,NTRA +C + F0 (I,JV)=ALF (I)* ( T0(1,JV)-ALF1(I)* + + ( TX(1,JV)-ALF2(I)*TXX(1,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(1,JV)-3.*ALF1(I)*TXX(1,JV)) + FXX(I,JV)=ALF3(I)*TXX(1,JV) + FY (I,JV)=ALF (I)*(TY(1,JV)-ALF1(I)*TXY(1,JV)) + FZ (I,JV)=ALF (I)*(TZ(1,JV)-ALF1(I)*TXZ(1,JV)) + FXY(I,JV)=ALFQ(I)*TXY(1,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(1,JV) + FYY(I,JV)=ALF (I)*TYY(1,JV) + FYZ(I,JV)=ALF (I)*TYZ(1,JV) + FZZ(I,JV)=ALF (I)*TZZ(1,JV) +C + T0 (1,JV)=T0(1,JV)-F0(I,JV) + TX (1,JV)=ALF1Q(I)*(TX(1,JV)+3.*ALF(I)*TXX(1,JV)) + TXX(1,JV)=ALF4(I)*TXX(1,JV) + TY (1,JV)=TY (1,JV)-FY (I,JV) + TZ (1,JV)=TZ (1,JV)-FZ (I,JV) + TYY(1,JV)=TYY(1,JV)-FYY(I,JV) + TYZ(1,JV)=TYZ(1,JV)-FYZ(I,JV) + TZZ(1,JV)=TZZ(1,JV)-FZZ(I,JV) + TXY(1,JV)=ALF1Q(I)*TXY(1,JV) + TXZ(1,JV)=ALF1Q(I)*TXZ(1,JV) +C + 151 CONTINUE +C + ENDIF +C + DO 152 JV=1,NTRA + DO 1520 I=1,LONK +C + IF(UEXT(I).GE.0.) THEN +C + F0 (I,JV)=ALF (I)* ( T0(I,JV)+ALF1(I)* + + ( TX(I,JV)+ALF2(I)*TXX(I,JV) ) ) + FX (I,JV)=ALFQ(I)*(TX(I,JV)+3.*ALF1(I)*TXX(I,JV)) + FXX(I,JV)=ALF3(I)*TXX(I,JV) + FY (I,JV)=ALF (I)*(TY(I,JV)+ALF1(I)*TXY(I,JV)) + FZ (I,JV)=ALF (I)*(TZ(I,JV)+ALF1(I)*TXZ(I,JV)) + FXY(I,JV)=ALFQ(I)*TXY(I,JV) + FXZ(I,JV)=ALFQ(I)*TXZ(I,JV) + FYY(I,JV)=ALF (I)*TYY(I,JV) + FYZ(I,JV)=ALF (I)*TYZ(I,JV) + FZZ(I,JV)=ALF (I)*TZZ(I,JV) +C + T0 (I,JV)=T0(I,JV)-F0(I,JV) + TX (I,JV)=ALF1Q(I)*(TX(I,JV)-3.*ALF(I)*TXX(I,JV)) + TXX(I,JV)=ALF4(I)*TXX(I,JV) + TY (I,JV)=TY (I,JV)-FY (I,JV) + TZ (I,JV)=TZ (I,JV)-FZ (I,JV) + TYY(I,JV)=TYY(I,JV)-FYY(I,JV) + TYZ(I,JV)=TYZ(I,JV)-FYZ(I,JV) + TZZ(I,JV)=TZZ(I,JV)-FZZ(I,JV) + TXY(I,JV)=ALF1Q(I)*TXY(I,JV) + TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) +C + ENDIF +C + 1520 CONTINUE + 152 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 160 I=1,LONK + IF(UEXT(I).LT.0.) THEN + TM(I)=TM(I)+FM(I) + ALF(I)=FM(I)/TM(I) + ENDIF + 160 CONTINUE +C + DO 161 I=1,LONK-1 + IF(UEXT(I).GE.0.) THEN + TM(I+1)=TM(I+1)+FM(I) + ALF(I)=FM(I)/TM(I+1) + ENDIF + 161 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + TM(1)=TM(1)+FM(I) + ALF(I)=FM(I)/TM(1) + ENDIF +C + DO 162 I=1,LONK + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALF1(I) + 162 CONTINUE +C + DO 170 JV=1,NTRA + DO 1700 I=1,LONK +C + IF(UEXT(I).LT.0.) THEN +C + TEMPTM=-ALF(I)*T0(I,JV)+ALF1(I)*F0(I,JV) + T0 (I,JV)=T0(I,JV)+F0(I,JV) + TXX(I,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I,JV) + + +5.*( ALF3(I)*(FX(I,JV)-TX(I,JV))+ALF2(I)*TEMPTM ) + TX (I,JV)=ALF (I)*FX (I,JV)+ALF1(I)*TX (I,JV)+3.*TEMPTM + TXY(I,JV)=ALF (I)*FXY(I,JV)+ALF1(I)*TXY(I,JV) + + +3.*(ALF1(I)*FY (I,JV)-ALF (I)*TY (I,JV)) + TXZ(I,JV)=ALF (I)*FXZ(I,JV)+ALF1(I)*TXZ(I,JV) + + +3.*(ALF1(I)*FZ (I,JV)-ALF (I)*TZ (I,JV)) + TY (I,JV)=TY (I,JV)+FY (I,JV) + TZ (I,JV)=TZ (I,JV)+FZ (I,JV) + TYY(I,JV)=TYY(I,JV)+FYY(I,JV) + TYZ(I,JV)=TYZ(I,JV)+FYZ(I,JV) + TZZ(I,JV)=TZZ(I,JV)+FZZ(I,JV) +C + ENDIF +C + 1700 CONTINUE + 170 CONTINUE +C + DO 171 JV=1,NTRA + DO 1710 I=1,LONK-1 +C + IF(UEXT(I).GE.0.) THEN +C + TEMPTM=ALF(I)*T0(I+1,JV)-ALF1(I)*F0(I,JV) + T0 (I+1,JV)=T0(I+1,JV)+F0(I,JV) + TXX(I+1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(I+1,JV) + + +5.*( ALF3(I)*(TX(I+1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) + TX (I+1,JV)=ALF(I)*FX (I ,JV)+ALF1(I)*TX (I+1,JV)+3.*TEMPTM + TXY(I+1,JV)=ALF(I)*FXY(I ,JV)+ALF1(I)*TXY(I+1,JV) + + +3.*(ALF(I)*TY (I+1,JV)-ALF1(I)*FY (I ,JV)) + TXZ(I+1,JV)=ALF(I)*FXZ(I ,JV)+ALF1(I)*TXZ(I+1,JV) + + +3.*(ALF(I)*TZ (I+1,JV)-ALF1(I)*FZ (I ,JV)) + TY (I+1,JV)=TY (I+1,JV)+FY (I,JV) + TZ (I+1,JV)=TZ (I+1,JV)+FZ (I,JV) + TYY(I+1,JV)=TYY(I+1,JV)+FYY(I,JV) + TYZ(I+1,JV)=TYZ(I+1,JV)+FYZ(I,JV) + TZZ(I+1,JV)=TZZ(I+1,JV)+FZZ(I,JV) +C + ENDIF +C + 1710 CONTINUE + 171 CONTINUE +C + I=LONK + IF(UEXT(I).GE.0.) THEN + DO 172 JV=1,NTRA + TEMPTM=ALF(I)*T0(1,JV)-ALF1(I)*F0(I,JV) + T0 (1,JV)=T0(1,JV)+F0(I,JV) + TXX(1,JV)=ALFQ(I)*FXX(I,JV)+ALF1Q(I)*TXX(1,JV) + + +5.*( ALF3(I)*(TX(1,JV)-FX(I,JV))-ALF2(I)*TEMPTM ) + TX (1,JV)=ALF(I)*FX(I,JV)+ALF1(I)*TX(1,JV)+3.*TEMPTM + TXY(1,JV)=ALF(I)*FXY(I,JV)+ALF1(I)*TXY(1,JV) + + +3.*(ALF(I)*TY (1,JV)-ALF1(I)*FY (I,JV)) + TXZ(1,JV)=ALF(I)*FXZ(I,JV)+ALF1(I)*TXZ(1,JV) + + +3.*(ALF(I)*TZ (1,JV)-ALF1(I)*FZ (I,JV)) + TY (1,JV)=TY (1,JV)+FY (I,JV) + TZ (1,JV)=TZ (1,JV)+FZ (I,JV) + TYY(1,JV)=TYY(1,JV)+FYY(I,JV) + TYZ(1,JV)=TYZ(1,JV)+FYZ(I,JV) + TZZ(1,JV)=TZZ(1,JV)+FZZ(I,JV) + 172 CONTINUE + ENDIF +C +C retour aux mailles d'origine (passage des Tij aux Sij) +C + IF(NUMK.GT.1) THEN +C + DO 18 I2=1,NUMK +C + DO 180 I=1,LONK +C + I3=I2+(I-1)*NUMK + SM(I3,K,L)=SMNEW(I3) + ALF(I)=SMNEW(I3)/TM(I) + TM(I)=TM(I)-SMNEW(I3) +C + ALFQ(I)=ALF(I)*ALF(I) + ALF1(I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF1(I)-ALF(I) + ALF3(I)=ALF(I)*ALFQ(I) + ALF4(I)=ALF1(I)*ALF1Q(I) +C + 180 CONTINUE +C + DO 181 JV=1,NTRA + DO 181 I=1,LONK +C + I3=I2+(I-1)*NUMK + S0 (I3,K,L,JV)=ALF (I)* ( T0(I,JV)-ALF1(I)* + + ( TX(I,JV)-ALF2(I)*TXX(I,JV) ) ) + SSX (I3,K,L,JV)=ALFQ(I)*(TX(I,JV)-3.*ALF1(I)*TXX(I,JV)) + SSXX(I3,K,L,JV)=ALF3(I)*TXX(I,JV) + SY (I3,K,L,JV)=ALF (I)*(TY(I,JV)-ALF1(I)*TXY(I,JV)) + SZ (I3,K,L,JV)=ALF (I)*(TZ(I,JV)-ALF1(I)*TXZ(I,JV)) + SSXY(I3,K,L,JV)=ALFQ(I)*TXY(I,JV) + SSXZ(I3,K,L,JV)=ALFQ(I)*TXZ(I,JV) + SYY(I3,K,L,JV)=ALF (I)*TYY(I,JV) + SYZ(I3,K,L,JV)=ALF (I)*TYZ(I,JV) + SZZ(I3,K,L,JV)=ALF (I)*TZZ(I,JV) +C +C reajusts moments remaining in the box +C + T0 (I,JV)=T0(I,JV)-S0(I3,K,L,JV) + TX (I,JV)=ALF1Q(I)*(TX(I,JV)+3.*ALF(I)*TXX(I,JV)) + TXX(I,JV)=ALF4 (I)*TXX(I,JV) + TY (I,JV)=TY (I,JV)-SY (I3,K,L,JV) + TZ (I,JV)=TZ (I,JV)-SZ (I3,K,L,JV) + TYY(I,JV)=TYY(I,JV)-SYY(I3,K,L,JV) + TYZ(I,JV)=TYZ(I,JV)-SYZ(I3,K,L,JV) + TZZ(I,JV)=TZZ(I,JV)-SZZ(I3,K,L,JV) + TXY(I,JV)=ALF1Q(I)*TXY(I,JV) + TXZ(I,JV)=ALF1Q(I)*TXZ(I,JV) +C + 181 CONTINUE +C + 18 CONTINUE +C + ELSE +C + DO 190 I=1,LON + SM(I,K,L)=TM(I) + 190 CONTINUE + DO 191 JV=1,NTRA + DO 1910 I=1,LON + S0 (I,K,L,JV)=T0 (I,JV) + SSX (I,K,L,JV)=TX (I,JV) + SY (I,K,L,JV)=TY (I,JV) + SZ (I,K,L,JV)=TZ (I,JV) + SSXX(I,K,L,JV)=TXX(I,JV) + SSXY(I,K,L,JV)=TXY(I,JV) + SSXZ(I,K,L,JV)=TXZ(I,JV) + SYY(I,K,L,JV)=TYY(I,JV) + SYZ(I,K,L,JV)=TYZ(I,JV) + SZZ(I,K,L,JV)=TZZ(I,JV) + 1910 CONTINUE + 191 CONTINUE +C + ENDIF +C + 1 CONTINUE +C +C ----------- AA Test en fin de ADVX ------ Controle des S* + +c DO 9999 l = 1, llm +c DO 9999 j = 1, jjp1 +c DO 9999 i = 1, iip1 +c IF (S0(i,j,l,ntra).lt.0..and.LIMIT) THEN +c PRINT*, '-------------------' +c PRINT*, 'En fin de ADVXP' +c PRINT*,'S0(',i,j,l,')=',S0(i,j,l,ntra) +c print*, 'SSX(',i,j,l,')=',SSX(i,j,l,ntra) +c print*, 'SY(',i,j,l,')=',SY(i,j,l,ntra) +c print*, 'SZ(',i,j,l,')=',SZ(i,j,l,ntra) +c WRITE (*,*) 'On arrete !! - pbl en fin de ADVXP' +c STOP +c ENDIF +c 9999 CONTINUE +c ---------- bouclage cyclique + + DO l = 1,llm + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,ntra) = S0(1,j,l,ntra) + SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) + SY(iip1,j,l,ntra) = SY(1,j,l,ntra) + SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) + END DO + END DO + +C ----------- qqtite totale de traceur dans tte l'atmosphere + DO l = 1, llm + DO j = 1, jjp1 + DO i = 1, iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO + + PRINT*,'------ DIAG DANS ADVX2 - SORTIE -----' + PRINT*,'sqf=',sqf +c------------------------------------------------------------- + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/advy.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advy.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advy.F (revision 1632) @@ -0,0 +1,422 @@ +! +! $Header$ +! + SUBROUTINE advy(limit,dty,pbarv,sm,s0,sx,sy,sz) + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C first-order moments (SOM) advection of tracer in Y direction C +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 15/12/94 LAST +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C +C parametres principaux du modele +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l + INTEGER ntra + PARAMETER (ntra = 1) + + REAL dty + REAL pbarv ( iip1,jjm, llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL sx(iip1,jjp1,llm,ntra) + + ,sy(iip1,jjp1,llm,ntra) + + ,sz(iip1,jjp1,llm,ntra) + + +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL VGRI(iip1,0:jjp1,llm) + +C Rem : UGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en y uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C + REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) + REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) + REAL FZ(iim,jjm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) + REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) + REAL TEMPTM ! Just temporal variable +c +C Special pour poles +c + REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn + REAL sns0(ntra),snsz(ntra),snsm + REAL s1v(llm),slatv(llm) + REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) + REAL cx1(llm,ntra), cxLAT(llm,ntra) + REAL cy1(llm,ntra), cyLAT(llm,ntra) + REAL z1(iim), zcos(iim), zsin(iim) + real smpn,smps,s0pn,s0ps + REAL SSUM + EXTERNAL SSUM +C + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv=llm + +C +C the moments Fi are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C + + DO l = 1,llm + DO j = 1,jjm + DO i = 1,iip1 + vgri (i,j,llm+1-l)=-1.*pbarv(i,j,l) + enddo + enddo + do i=1,iip1 + vgri(i,0,l) = 0. + vgri(i,jjp1,l) = 0. + enddo + enddo + + DO 1 L=1,NIV +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 11 +C + DO 10 JV=1,NTRA + DO 10 K=1,LAT + DO 100 I=1,LON + sy(I,K,L,JV)=SIGN(AMIN1(AMAX1(S0(I,K,L,JV),0.), + + ABS(sy(I,K,L,JV))),sy(I,K,L,JV)) + 100 CONTINUE + 10 CONTINUE +C + 11 CONTINUE +C +C le flux a travers le pole Nord est traite separement +C + SM0=0. + DO 20 JV=1,NTRA + S00(JV)=0. + 20 CONTINUE +C + DO 21 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN + FM(I,0)=-VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM(I,1,L) + SM(I,1,L)=SM(I,1,L)-FM(I,0) + SM0=SM0+FM(I,0) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) +C + 21 CONTINUE +C + DO 22 JV=1,NTRA + DO 220 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN +C + F0(I,0,JV)=ALF(I,0)* + + ( S0(I,1,L,JV)-ALF1(I,0)*sy(I,1,L,JV) ) +C + S00(JV)=S00(JV)+F0(I,0,JV) + S0(I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) + sy(I,1,L,JV)=ALF1Q(I,0)*sy(I,1,L,JV) + sx(I,1,L,JV)=ALF1 (I,0)*sx(I,1,L,JV) + sz(I,1,L,JV)=ALF1 (I,0)*sz(I,1,L,JV) +C + ENDIF +C + 220 CONTINUE + 22 CONTINUE +C + DO 23 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + FM(I,0)=VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM0 + ENDIF + 23 CONTINUE +C + DO 24 JV=1,NTRA + DO 240 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + F0(I,0,JV)=ALF(I,0)*S00(JV) + ENDIF + 240 CONTINUE + 24 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 25 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN + SM(I,1,L)=SM(I,1,L)+FM(I,0) + ALF(I,0)=FM(I,0)/SM(I,1,L) + ENDIF +C + ALF1(I,0)=1.-ALF(I,0) +C + 25 CONTINUE +C + DO 26 JV=1,NTRA + DO 260 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN +C + TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) + S0(I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) + sy(I,1,L,JV)=ALF1(I,0)*sy(I,1,L,JV)+3.*TEMPTM +C + ENDIF +C + 260 CONTINUE + 26 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 +C + DO 30 K=1,LAT-1 + KP=K+1 + DO 300 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,KP,L) + SM(I,KP,L)=SM(I,KP,L)-FM(I,K) + ELSE + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) +C + 300 CONTINUE + 30 CONTINUE +C + DO 31 JV=1,NTRA + DO 31 K=1,LAT-1 + KP=K+1 + DO 310 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + F0(I,K,JV)=ALF (I,K)* + + ( S0(I,KP,L,JV)-ALF1(I,K)*sy(I,KP,L,JV) ) + FY(I,K,JV)=ALFQ(I,K)*sy(I,KP,L,JV) + FX(I,K,JV)=ALF (I,K)*sx(I,KP,L,JV) + FZ(I,K,JV)=ALF (I,K)*sz(I,KP,L,JV) +C + S0(I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) + sy(I,KP,L,JV)=ALF1Q(I,K)*sy(I,KP,L,JV) + sx(I,KP,L,JV)=sx(I,KP,L,JV)-FX(I,K,JV) + sz(I,KP,L,JV)=sz(I,KP,L,JV)-FZ(I,K,JV) +C + ELSE +C + F0(I,K,JV)=ALF (I,K)* + + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) + FY(I,K,JV)=ALFQ(I,K)*sy(I,K,L,JV) + FX(I,K,JV)=ALF(I,K)*sx(I,K,L,JV) + FZ(I,K,JV)=ALF(I,K)*sz(I,K,L,JV) +C + S0(I,K,L,JV)=S0(I,K,L,JV)-F0(I,K,JV) + sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) + sx(I,K,L,JV)=sx(I,K,L,JV)-FX(I,K,JV) + sz(I,K,L,JV)=sz(I,K,L,JV)-FZ(I,K,JV) +C + ENDIF +C + 310 CONTINUE + 31 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 32 K=1,LAT-1 + KP=K+1 + DO 320 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ELSE + SM(I,KP,L)=SM(I,KP,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,KP,L) + ENDIF +C + ALF1(I,K)=1.-ALF(I,K) +C + 320 CONTINUE + 32 CONTINUE +C + DO 33 JV=1,NTRA + DO 33 K=1,LAT-1 + KP=K+1 + DO 330 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + sy(I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,K,L,JV) + + +3.*TEMPTM + sx(I,K,L,JV)=sx(I,K,L,JV)+FX(I,K,JV) + sz(I,K,L,JV)=sz(I,K,L,JV)+FZ(I,K,JV) +C + ELSE +C + TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) + S0(I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) + sy(I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*sy(I,KP,L,JV) + + +3.*TEMPTM + sx(I,KP,L,JV)=sx(I,KP,L,JV)+FX(I,K,JV) + sz(I,KP,L,JV)=sz(I,KP,L,JV)+FZ(I,K,JV) +C + ENDIF +C + 330 CONTINUE + 33 CONTINUE +C +C traitement special pour le pole Sud (idem pole Nord) +C + K=LAT +C + SM0=0. + DO 40 JV=1,NTRA + S00(JV)=0. + 40 CONTINUE +C + DO 41 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + SM0=SM0+FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) +C + 41 CONTINUE +C + DO 42 JV=1,NTRA + DO 420 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + F0 (I,K,JV)=ALF(I,K)* + + ( S0(I,K,L,JV)+ALF1(I,K)*sy(I,K,L,JV) ) + S00(JV)=S00(JV)+F0(I,K,JV) +C + S0(I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + sy(I,K,L,JV)=ALF1Q(I,K)*sy(I,K,L,JV) + sx(I,K,L,JV)=ALF1(I,K)*sx(I,K,L,JV) + sz(I,K,L,JV)=ALF1(I,K)*sz(I,K,L,JV) + ENDIF +C + 420 CONTINUE + 42 CONTINUE +C + DO 43 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM0 + ENDIF + 43 CONTINUE +C + DO 44 JV=1,NTRA + DO 440 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + F0(I,K,JV)=ALF(I,K)*S00(JV) + ENDIF + 440 CONTINUE + 44 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 45 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ENDIF +C + ALF1(I,K)=1.-ALF(I,K) +C + 45 CONTINUE +C + DO 46 JV=1,NTRA + DO 460 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0(I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + sy(I,K,L,JV)=ALF1(I,K)*sy(I,K,L,JV)+3.*TEMPTM +C + ENDIF +C + 460 CONTINUE + 46 CONTINUE +C + 1 CONTINUE +C + RETURN + END + Index: /LMDZ5/trunk/libf/dyn3dmem/advyp.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advyp.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advyp.F (revision 1632) @@ -0,0 +1,653 @@ +! +! $Header$ +! + SUBROUTINE ADVYP(LIMIT,DTY,PBARV,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) + IMPLICIT NONE +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in Y direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 19/10/95 LAST +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C +C parametres principaux du modele +C +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 + + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l + INTEGER ntra +C PARAMETER (ntra = 1) + + REAL dty + REAL pbarv ( iip1,jjm, llm ) + +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + + ,SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) +C +C Local : +C ------- + +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : + + REAL VGRI(iip1,0:jjp1,llm) + +C Rem : UGRI et WGRI ne sont pas utilises dans +C cette subroutine ( advection en y uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C +C the moments Fij are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C +C + REAL F0(iim,0:jjp1,ntra),FM(iim,0:jjp1) + REAL FX(iim,jjm,ntra),FY(iim,jjm,ntra) + REAL FZ(iim,jjm,ntra) + REAL FXX(iim,jjm,ntra),FXY(iim,jjm,ntra) + REAL FXZ(iim,jjm,ntra),FYY(iim,jjm,ntra) + REAL FYZ(iim,jjm,ntra),FZZ(iim,jjm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim,0:jjp1),ALF1(iim,0:jjp1) + REAL ALFQ(iim,0:jjp1),ALF1Q(iim,0:jjp1) + REAL ALF2(iim,0:jjp1),ALF3(iim,0:jjp1) + REAL ALF4(iim,0:jjp1) + REAL TEMPTM ! Just temporal variable + REAL SLPMAX,S1MAX,S1NEW,S2NEW +c +C Special pour poles +c + REAL sbms,sfms,sfzs,sbmn,sfmn,sfzn + REAL sns0(ntra),snsz(ntra),snsm + REAL qy1(iim,llm,ntra),qylat(iim,llm,ntra) + REAL cx1(llm,ntra), cxLAT(llm,ntra) + REAL cy1(llm,ntra), cyLAT(llm,ntra) + REAL z1(iim), zcos(iim), zsin(iim) + REAL SSUM + EXTERNAL SSUM +C + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv = llm ! tab. S et VGRI + +c----------------------------------------------------------------- +C initialisations + + sbms = 0. + sfms = 0. + sfzs = 0. + sbmn = 0. + sfmn = 0. + sfzn = 0. + +c----------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y +c + sqi = 0. + sqf = 0. + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVY - ENTREE --------' + PRINT*,'sqi=',sqi + +c----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion des flux de masses en kg +C-AA 20/10/94 le signe -1 est necessaire car indexation opposee + + DO 500 l = 1,llm + DO 500 j = 1,jjm + DO 500 i = 1,iip1 + vgri (i,j,llm+1-l)=-1.*pbarv (i,j,l) + 500 CONTINUE + +CAA Initialisation de flux fictifs aux bords sup. des boites pol. + + DO l = 1,llm + DO i = 1,iip1 + vgri(i,0,l) = 0. + vgri(i,jjp1,l) = 0. + ENDDO + ENDDO +c +c----------------- START HERE ----------------------- +C boucle sur les niveaux +C + DO 1 L=1,NIV +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 11 +C + DO 10 JV=1,NTRA + DO 10 K=1,LAT + DO 100 I=1,LON + IF(S0(I,K,L,JV).GT.0.) THEN + SLPMAX=AMAX1(S0(I,K,L,JV),0.) + S1MAX=1.5*SLPMAX + S1NEW=AMIN1(S1MAX,AMAX1(-S1MAX,SY(I,K,L,JV))) + S2NEW=AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,SYY(I,K,L,JV)) ) + SY (I,K,L,JV)=S1NEW + SYY(I,K,L,JV)=S2NEW + SSXY(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXY(I,K,L,JV))) + SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) + ELSE + SY (I,K,L,JV)=0. + SYY(I,K,L,JV)=0. + SSXY(I,K,L,JV)=0. + SYZ(I,K,L,JV)=0. + ENDIF + 100 CONTINUE + 10 CONTINUE +C + 11 CONTINUE +C +C le flux a travers le pole Nord est traite separement +C + SM0=0. + DO 20 JV=1,NTRA + S00(JV)=0. + 20 CONTINUE +C + DO 21 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN + FM(I,0)=-VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM(I,1,L) + SM(I,1,L)=SM(I,1,L)-FM(I,0) + SM0=SM0+FM(I,0) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) + ALF2(I,0)=ALF1(I,0)-ALF(I,0) + ALF3(I,0)=ALF(I,0)*ALFQ(I,0) + ALF4(I,0)=ALF1(I,0)*ALF1Q(I,0) +C + 21 CONTINUE +c print*,'ADVYP 21' +C + DO 22 JV=1,NTRA + DO 220 I=1,LON +C + IF(VGRI(I,0,L).LE.0.) THEN +C + F0(I,0,JV)=ALF(I,0)* ( S0(I,1,L,JV)-ALF1(I,0)* + + ( SY(I,1,L,JV)-ALF2(I,0)*SYY(I,1,L,JV) ) ) +C + S00(JV)=S00(JV)+F0(I,0,JV) + S0 (I,1,L,JV)=S0(I,1,L,JV)-F0(I,0,JV) + SY (I,1,L,JV)=ALF1Q(I,0)* + + (SY(I,1,L,JV)+3.*ALF(I,0)*SYY(I,1,L,JV)) + SYY(I,1,L,JV)=ALF4 (I,0)*SYY(I,1,L,JV) + SSX (I,1,L,JV)=ALF1 (I,0)* + + (SSX(I,1,L,JV)+ALF(I,0)*SSXY(I,1,L,JV) ) + SZ (I,1,L,JV)=ALF1 (I,0)* + + (SZ(I,1,L,JV)+ALF(I,0)*SSXZ(I,1,L,JV) ) + SSXX(I,1,L,JV)=ALF1 (I,0)*SSXX(I,1,L,JV) + SSXZ(I,1,L,JV)=ALF1 (I,0)*SSXZ(I,1,L,JV) + SZZ(I,1,L,JV)=ALF1 (I,0)*SZZ(I,1,L,JV) + SSXY(I,1,L,JV)=ALF1Q(I,0)*SSXY(I,1,L,JV) + SYZ(I,1,L,JV)=ALF1Q(I,0)*SYZ(I,1,L,JV) +C + ENDIF +C + 220 CONTINUE + 22 CONTINUE +C + DO 23 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + FM(I,0)=VGRI(I,0,L)*DTY + ALF(I,0)=FM(I,0)/SM0 + ENDIF + 23 CONTINUE +C + DO 24 JV=1,NTRA + DO 240 I=1,LON + IF(VGRI(I,0,L).GT.0.) THEN + F0(I,0,JV)=ALF(I,0)*S00(JV) + ENDIF + 240 CONTINUE + 24 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C +c print*,'av ADVYP 25' + DO 25 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN + SM(I,1,L)=SM(I,1,L)+FM(I,0) + ALF(I,0)=FM(I,0)/SM(I,1,L) + ENDIF +C + ALFQ(I,0)=ALF(I,0)*ALF(I,0) + ALF1(I,0)=1.-ALF(I,0) + ALF1Q(I,0)=ALF1(I,0)*ALF1(I,0) + ALF2(I,0)=ALF1(I,0)-ALF(I,0) + ALF3(I,0)=ALF1(I,0)*ALF(I,0) +C + 25 CONTINUE +c print*,'av ADVYP 25' +C + DO 26 JV=1,NTRA + DO 260 I=1,LON +C + IF(VGRI(I,0,L).GT.0.) THEN +C + TEMPTM=ALF(I,0)*S0(I,1,L,JV)-ALF1(I,0)*F0(I,0,JV) + S0 (I,1,L,JV)=S0(I,1,L,JV)+F0(I,0,JV) + SYY(I,1,L,JV)=ALF1Q(I,0)*SYY(I,1,L,JV) + + +5.*( ALF3 (I,0)*SY (I,1,L,JV)-ALF2(I,0)*TEMPTM ) + SY (I,1,L,JV)=ALF1 (I,0)*SY (I,1,L,JV)+3.*TEMPTM + SSXY(I,1,L,JV)=ALF1 (I,0)*SSXY(I,1,L,JV)+3.*ALF(I,0)*SSX(I,1,L,JV) + SYZ(I,1,L,JV)=ALF1 (I,0)*SYZ(I,1,L,JV)+3.*ALF(I,0)*SZ(I,1,L,JV) +C + ENDIF +C + 260 CONTINUE + 26 CONTINUE +C +C calculate flux and moments between adjacent boxes +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C +C flux from KP to K if V(K).lt.0 and from K to KP if V(K).gt.0 +C +c print*,'av ADVYP 30' + DO 30 K=1,LAT-1 + KP=K+1 + DO 300 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,KP,L) + SM(I,KP,L)=SM(I,KP,L)-FM(I,K) + ELSE + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF(I,K)*ALFQ(I,K) + ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) +C + 300 CONTINUE + 30 CONTINUE +c print*,'ap ADVYP 30' +C + DO 31 JV=1,NTRA + DO 31 K=1,LAT-1 + KP=K+1 + DO 310 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + F0 (I,K,JV)=ALF (I,K)* ( S0(I,KP,L,JV)-ALF1(I,K)* + + ( SY(I,KP,L,JV)-ALF2(I,K)*SYY(I,KP,L,JV) ) ) + FY (I,K,JV)=ALFQ(I,K)* + + (SY(I,KP,L,JV)-3.*ALF1(I,K)*SYY(I,KP,L,JV)) + FYY(I,K,JV)=ALF3(I,K)*SYY(I,KP,L,JV) + FX (I,K,JV)=ALF (I,K)* + + (SSX(I,KP,L,JV)-ALF1(I,K)*SSXY(I,KP,L,JV)) + FZ (I,K,JV)=ALF (I,K)* + + (SZ(I,KP,L,JV)-ALF1(I,K)*SYZ(I,KP,L,JV)) + FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,KP,L,JV) + FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,KP,L,JV) + FXX(I,K,JV)=ALF (I,K)*SSXX(I,KP,L,JV) + FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,KP,L,JV) + FZZ(I,K,JV)=ALF (I,K)*SZZ(I,KP,L,JV) +C + S0 (I,KP,L,JV)=S0(I,KP,L,JV)-F0(I,K,JV) + SY (I,KP,L,JV)=ALF1Q(I,K)* + + (SY(I,KP,L,JV)+3.*ALF(I,K)*SYY(I,KP,L,JV)) + SYY(I,KP,L,JV)=ALF4(I,K)*SYY(I,KP,L,JV) + SSX (I,KP,L,JV)=SSX (I,KP,L,JV)-FX (I,K,JV) + SZ (I,KP,L,JV)=SZ (I,KP,L,JV)-FZ (I,K,JV) + SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)-FXX(I,K,JV) + SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)-FXZ(I,K,JV) + SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)-FZZ(I,K,JV) + SSXY(I,KP,L,JV)=ALF1Q(I,K)*SSXY(I,KP,L,JV) + SYZ(I,KP,L,JV)=ALF1Q(I,K)*SYZ(I,KP,L,JV) +C + ELSE +C + F0 (I,K,JV)=ALF (I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* + + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) + FY (I,K,JV)=ALFQ(I,K)* + + (SY(I,K,L,JV)+3.*ALF1(I,K)*SYY(I,K,L,JV)) + FYY(I,K,JV)=ALF3(I,K)*SYY(I,K,L,JV) + FX (I,K,JV)=ALF (I,K)*(SSX(I,K,L,JV)+ALF1(I,K)*SSXY(I,K,L,JV)) + FZ (I,K,JV)=ALF (I,K)*(SZ(I,K,L,JV)+ALF1(I,K)*SYZ(I,K,L,JV)) + FXY(I,K,JV)=ALFQ(I,K)*SSXY(I,K,L,JV) + FYZ(I,K,JV)=ALFQ(I,K)*SYZ(I,K,L,JV) + FXX(I,K,JV)=ALF (I,K)*SSXX(I,K,L,JV) + FXZ(I,K,JV)=ALF (I,K)*SSXZ(I,K,L,JV) + FZZ(I,K,JV)=ALF (I,K)*SZZ(I,K,L,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + SY (I,K,L,JV)=ALF1Q(I,K)* + + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) + SYY(I,K,L,JV)=ALF4(I,K)*SYY(I,K,L,JV) + SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,K,JV) + SZ (I,K,L,JV)=SZ (I,K,L,JV)-FZ (I,K,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,K,JV) + SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)-FXZ(I,K,JV) + SZZ(I,K,L,JV)=SZZ(I,K,L,JV)-FZZ(I,K,JV) + SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) +C + ENDIF +C + 310 CONTINUE + 31 CONTINUE +c print*,'ap ADVYP 31' +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 32 K=1,LAT-1 + KP=K+1 + DO 320 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ELSE + SM(I,KP,L)=SM(I,KP,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,KP,L) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF1(I,K)*ALF(I,K) +C + 320 CONTINUE + 32 CONTINUE +c print*,'ap ADVYP 32' +C + DO 33 JV=1,NTRA + DO 33 K=1,LAT-1 + KP=K+1 + DO 330 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + SYY(I,K,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,K,L,JV) + + +5.*( ALF3(I,K)*(FY(I,K,JV)-SY(I,K,L,JV))+ALF2(I,K)*TEMPTM ) + SY (I,K,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,K,L,JV) + + +3.*TEMPTM + SSXY(I,K,L,JV)=ALF (I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,K,L,JV) + + +3.*(ALF1(I,K)*FX (I,K,JV)-ALF (I,K)*SSX (I,K,L,JV)) + SYZ(I,K,L,JV)=ALF (I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,K,L,JV) + + +3.*(ALF1(I,K)*FZ (I,K,JV)-ALF (I,K)*SZ (I,K,L,JV)) + SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,K,JV) + SZ (I,K,L,JV)=SZ (I,K,L,JV)+FZ (I,K,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,K,JV) + SSXZ(I,K,L,JV)=SSXZ(I,K,L,JV)+FXZ(I,K,JV) + SZZ(I,K,L,JV)=SZZ(I,K,L,JV)+FZZ(I,K,JV) +C + ELSE +C + TEMPTM=ALF(I,K)*S0(I,KP,L,JV)-ALF1(I,K)*F0(I,K,JV) + S0 (I,KP,L,JV)=S0(I,KP,L,JV)+F0(I,K,JV) + SYY(I,KP,L,JV)=ALFQ(I,K)*FYY(I,K,JV)+ALF1Q(I,K)*SYY(I,KP,L,JV) + + +5.*( ALF3(I,K)*(SY(I,KP,L,JV)-FY(I,K,JV))-ALF2(I,K)*TEMPTM ) + SY (I,KP,L,JV)=ALF(I,K)*FY(I,K,JV)+ALF1(I,K)*SY(I,KP,L,JV) + + +3.*TEMPTM + SSXY(I,KP,L,JV)=ALF(I,K)*FXY(I,K,JV)+ALF1(I,K)*SSXY(I,KP,L,JV) + + +3.*(ALF(I,K)*SSX(I,KP,L,JV)-ALF1(I,K)*FX(I,K,JV)) + SYZ(I,KP,L,JV)=ALF(I,K)*FYZ(I,K,JV)+ALF1(I,K)*SYZ(I,KP,L,JV) + + +3.*(ALF(I,K)*SZ(I,KP,L,JV)-ALF1(I,K)*FZ(I,K,JV)) + SSX (I,KP,L,JV)=SSX (I,KP,L,JV)+FX (I,K,JV) + SZ (I,KP,L,JV)=SZ (I,KP,L,JV)+FZ (I,K,JV) + SSXX(I,KP,L,JV)=SSXX(I,KP,L,JV)+FXX(I,K,JV) + SSXZ(I,KP,L,JV)=SSXZ(I,KP,L,JV)+FXZ(I,K,JV) + SZZ(I,KP,L,JV)=SZZ(I,KP,L,JV)+FZZ(I,K,JV) +C + ENDIF +C + 330 CONTINUE + 33 CONTINUE +c print*,'ap ADVYP 33' +C +C traitement special pour le pole Sud (idem pole Nord) +C + K=LAT +C + SM0=0. + DO 40 JV=1,NTRA + S00(JV)=0. + 40 CONTINUE +C + DO 41 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + FM(I,K)=VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,K) + SM0=SM0+FM(I,K) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF(I,K)*ALFQ(I,K) + ALF4(I,K)=ALF1(I,K)*ALF1Q(I,K) +C + 41 CONTINUE +c print*,'ap ADVYP 41' +C + DO 42 JV=1,NTRA + DO 420 I=1,LON +C + IF(VGRI(I,K,L).GE.0.) THEN + F0 (I,K,JV)=ALF(I,K)* ( S0(I,K,L,JV)+ALF1(I,K)* + + ( SY(I,K,L,JV)+ALF2(I,K)*SYY(I,K,L,JV) ) ) + S00(JV)=S00(JV)+F0(I,K,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0 (I,K,JV) + SY (I,K,L,JV)=ALF1Q(I,K)* + + (SY(I,K,L,JV)-3.*ALF(I,K)*SYY(I,K,L,JV)) + SYY(I,K,L,JV)=ALF4 (I,K)*SYY(I,K,L,JV) + SSX (I,K,L,JV)=ALF1(I,K)*(SSX(I,K,L,JV)-ALF(I,K)*SSXY(I,K,L,JV)) + SZ (I,K,L,JV)=ALF1(I,K)*(SZ(I,K,L,JV)-ALF(I,K)*SYZ(I,K,L,JV)) + SSXX(I,K,L,JV)=ALF1 (I,K)*SSXX(I,K,L,JV) + SSXZ(I,K,L,JV)=ALF1 (I,K)*SSXZ(I,K,L,JV) + SZZ(I,K,L,JV)=ALF1 (I,K)*SZZ(I,K,L,JV) + SSXY(I,K,L,JV)=ALF1Q(I,K)*SSXY(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I,K)*SYZ(I,K,L,JV) + ENDIF +C + 420 CONTINUE + 42 CONTINUE +c print*,'ap ADVYP 42' +C + DO 43 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + FM(I,K)=-VGRI(I,K,L)*DTY + ALF(I,K)=FM(I,K)/SM0 + ENDIF + 43 CONTINUE +c print*,'ap ADVYP 43' +C + DO 44 JV=1,NTRA + DO 440 I=1,LON + IF(VGRI(I,K,L).LT.0.) THEN + F0(I,K,JV)=ALF(I,K)*S00(JV) + ENDIF + 440 CONTINUE + 44 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 45 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,K) + ALF(I,K)=FM(I,K)/SM(I,K,L) + ENDIF +C + ALFQ(I,K)=ALF(I,K)*ALF(I,K) + ALF1(I,K)=1.-ALF(I,K) + ALF1Q(I,K)=ALF1(I,K)*ALF1(I,K) + ALF2(I,K)=ALF1(I,K)-ALF(I,K) + ALF3(I,K)=ALF1(I,K)*ALF(I,K) +C + 45 CONTINUE +c print*,'ap ADVYP 45' +C + DO 46 JV=1,NTRA + DO 460 I=1,LON +C + IF(VGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I,K)*S0(I,K,L,JV)+ALF1(I,K)*F0(I,K,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,K,JV) + SYY(I,K,L,JV)=ALF1Q(I,K)*SYY(I,K,L,JV) + + +5.*(-ALF3 (I,K)*SY (I,K,L,JV)+ALF2(I,K)*TEMPTM ) + SY (I,K,L,JV)=ALF1(I,K)*SY (I,K,L,JV)+3.*TEMPTM + SSXY(I,K,L,JV)=ALF1(I,K)*SSXY(I,K,L,JV)-3.*ALF(I,K)*SSX(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1(I,K)*SYZ(I,K,L,JV)-3.*ALF(I,K)*SZ(I,K,L,JV) +C + ENDIF +C + 460 CONTINUE + 46 CONTINUE +c print*,'ap ADVYP 46' +C + 1 CONTINUE + +c-------------------------------------------------- +C bouclage cyclique horizontal . + + DO l = 1,llm + DO jv = 1,ntra + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,jv) = S0(1,j,l,jv) + SSX(iip1,j,l,jv) = SSX(1,j,l,jv) + SY(iip1,j,l,jv) = SY(1,j,l,jv) + SZ(iip1,j,l,jv) = SZ(1,j,l,jv) + END DO + END DO + END DO + +c ------------------------------------------------------------------- +C *** Test negativite: + +c DO jv = 1,ntra +c DO l = 1,llm +c DO j = 1,jjp1 +c DO i = 1,iip1 +c IF (s0( i,j,l,jv ).lt.0.) THEN +c PRINT*, '------ S0 < 0 en FIN ADVYP ---' +c PRINT*, 'S0(',i,j,l,jv,')=', S0(i,j,l,jv) +cc STOP +c ENDIF +c ENDDO +c ENDDO +c ENDDO +c ENDDO + + +c ------------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y + + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVY - SORTIE --------' + PRINT*,'sqf=',sqf +c print*,'ap ADVYP fin' + +c----------------------------------------------------------------- +C + RETURN + END + + + + + + + + + + + + Index: /LMDZ5/trunk/libf/dyn3dmem/advz.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advz.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advz.F (revision 1632) @@ -0,0 +1,320 @@ +! +! $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 + 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 + 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/dyn3dmem/advzp.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/advzp.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/advzp.F (revision 1632) @@ -0,0 +1,378 @@ +! +! $Header$ +! + SUBROUTINE ADVZP(LIMIT,DTZ,W,SM,S0,SSX,SY,SZ + . ,SSXX,SSXY,SSXZ,SYY,SYZ,SZZ,ntra ) + + IMPLICIT NONE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C second-order moments (SOM) advection of tracer in Z direction C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C C +C Source : Pascal Simon ( Meteo, CNRM ) C +C Adaptation : A.A. (LGGE) C +C Derniere Modif : 19/11/95 LAST C +C C +C sont les arguments d'entree pour le s-pg C +C C +C argument de sortie du s-pg C +C C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C Rem : Probleme aux poles il faut reecrire ce cas specifique +C Attention au sens de l'indexation +C + +C +C parametres principaux du modele +C +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +C +C Arguments : +C ---------- +C dty : frequence fictive d'appel du transport +C parbu,pbarv : flux de masse en x et y en Pa.m2.s-1 +c + INTEGER lon,lat,niv + INTEGER i,j,jv,k,kp,l,lp + INTEGER ntra +c PARAMETER (ntra = 1) +c + REAL dtz + REAL w ( iip1,jjp1,llm ) +c +C moments: SM total mass in each grid box +C S0 mass of tracer in each grid box +C Si 1rst order moment in i direction +C + REAL SM(iip1,jjp1,llm) + + ,S0(iip1,jjp1,llm,ntra) + REAL SSX(iip1,jjp1,llm,ntra) + + ,SY(iip1,jjp1,llm,ntra) + + ,SZ(iip1,jjp1,llm,ntra) + + ,SSXX(iip1,jjp1,llm,ntra) + + ,SSXY(iip1,jjp1,llm,ntra) + + ,SSXZ(iip1,jjp1,llm,ntra) + + ,SYY(iip1,jjp1,llm,ntra) + + ,SYZ(iip1,jjp1,llm,ntra) + + ,SZZ(iip1,jjp1,llm,ntra) +C +C Local : +C ------- +C +C mass fluxes across the boundaries (UGRI,VGRI,WGRI) +C mass fluxes in kg +C declaration : +C + REAL WGRI(iip1,jjp1,0:llm) + +C Rem : UGRI et VGRI ne sont pas utilises dans +C cette subroutine ( advection en z uniquement ) +C Rem 2 :le dimensionnement de VGRI depend de celui de pbarv +C attention a celui de WGRI +C +C the moments F are similarly defined and used as temporary +C storage for portions of the grid boxes in transit +C +C the moments Fij are used as temporary storage for +C portions of the grid boxes in transit at the current level +C +C work arrays +C +C + REAL F0(iim,llm,ntra),FM(iim,llm) + REAL FX(iim,llm,ntra),FY(iim,llm,ntra) + REAL FZ(iim,llm,ntra) + REAL FXX(iim,llm,ntra),FXY(iim,llm,ntra) + REAL FXZ(iim,llm,ntra),FYY(iim,llm,ntra) + REAL FYZ(iim,llm,ntra),FZZ(iim,llm,ntra) + REAL S00(ntra) + REAL SM0 ! Just temporal variable +C +C work arrays +C + REAL ALF(iim),ALF1(iim) + REAL ALFQ(iim),ALF1Q(iim) + REAL ALF2(iim),ALF3(iim) + REAL ALF4(iim) + REAL TEMPTM ! Just temporal variable + REAL SLPMAX,S1MAX,S1NEW,S2NEW +c + REAL sqi,sqf + LOGICAL LIMIT + + lon = iim ! rem : Il est possible qu'un pbl. arrive ici + lat = jjp1 ! a cause des dim. differentes entre les + niv = llm ! tab. S et VGRI + +c----------------------------------------------------------------- +C *** Test : diag de la qtite totale de traceur dans +C l'atmosphere avant l'advection en Y +c + sqi = 0. + sqf = 0. +c + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqi = sqi + S0(i,j,l,ntra) + END DO + END DO + END DO + PRINT*,'---------- DIAG DANS ADVZP - ENTREE --------' + PRINT*,'sqi=',sqi + +c----------------------------------------------------------------- +C Interface : adaptation nouveau modele +C ------------------------------------- +C +C Conversion des flux de masses en kg + + DO 500 l = 1,llm + DO 500 j = 1,jjp1 + DO 500 i = 1,iip1 + wgri (i,j,llm+1-l) = w (i,j,l) + 500 CONTINUE + do j=1,jjp1 + do i=1,iip1 + wgri(i,j,0)=0. + enddo + enddo +c +cAA rem : Je ne suis pas sur du signe +cAA Je ne suis pas sur pour le 0:llm +c +c----------------------------------------------------------------- +C---------------------- START HERE ------------------------------- +C +C boucle sur les latitudes +C + DO 1 K=1,LAT +C +C place limits on appropriate moments before transport +C (if flux-limiting is to be applied) +C + IF(.NOT.LIMIT) GO TO 101 +C + DO 10 JV=1,NTRA + DO 10 L=1,NIV + DO 100 I=1,LON + IF(S0(I,K,L,JV).GT.0.) THEN + SLPMAX=S0(I,K,L,JV) + S1MAX =1.5*SLPMAX + S1NEW =AMIN1(S1MAX,AMAX1(-S1MAX,SZ(I,K,L,JV))) + S2NEW =AMIN1( 2.*SLPMAX-ABS(S1NEW)/3. , + + AMAX1(ABS(S1NEW)-SLPMAX,SZZ(I,K,L,JV)) ) + SZ (I,K,L,JV)=S1NEW + SZZ(I,K,L,JV)=S2NEW + SSXZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SSXZ(I,K,L,JV))) + SYZ(I,K,L,JV)=AMIN1(SLPMAX,AMAX1(-SLPMAX,SYZ(I,K,L,JV))) + ELSE + SZ (I,K,L,JV)=0. + SZZ(I,K,L,JV)=0. + SSXZ(I,K,L,JV)=0. + SYZ(I,K,L,JV)=0. + ENDIF + 100 CONTINUE + 10 CONTINUE +C + 101 CONTINUE +C +C boucle sur les niveaux intercouches de 1 a NIV-1 +C (flux nul au sommet L=0 et a la base L=NIV) +C +C calculate flux and moments between adjacent boxes +C (flux from LP to L if WGRI(L).lt.0, from L to LP if WGRI(L).gt.0) +C 1- create temporary moments/masses for partial boxes in transit +C 2- reajusts moments remaining in the box +C + DO 11 L=1,NIV-1 + LP=L+1 +C + DO 110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + FM(I,L)=-WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,LP) + SM(I,K,LP)=SM(I,K,LP)-FM(I,L) + ELSE + FM(I,L)=WGRI(I,K,L)*DTZ + ALF(I)=FM(I,L)/SM(I,K,L) + SM(I,K,L)=SM(I,K,L)-FM(I,L) + ENDIF +C + ALFQ (I)=ALF(I)*ALF(I) + ALF1 (I)=1.-ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2 (I)=ALF1(I)-ALF(I) + ALF3 (I)=ALF(I)*ALFQ(I) + ALF4 (I)=ALF1(I)*ALF1Q(I) +C + 110 CONTINUE +C + DO 111 JV=1,NTRA + DO 1110 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + F0 (I,L,JV)=ALF (I)* ( S0(I,K,LP,JV)-ALF1(I)* + + ( SZ(I,K,LP,JV)-ALF2(I)*SZZ(I,K,LP,JV) ) ) + FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,LP,JV)-3.*ALF1(I)*SZZ(I,K,LP,JV)) + FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,LP,JV) + FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,LP,JV) + FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,LP,JV) + FX (I,L,JV)=ALF (I)*(SSX(I,K,LP,JV)-ALF1(I)*SSXZ(I,K,LP,JV)) + FY (I,L,JV)=ALF (I)*(SY(I,K,LP,JV)-ALF1(I)*SYZ(I,K,LP,JV)) + FXX(I,L,JV)=ALF (I)*SSXX(I,K,LP,JV) + FXY(I,L,JV)=ALF (I)*SSXY(I,K,LP,JV) + FYY(I,L,JV)=ALF (I)*SYY(I,K,LP,JV) +C + S0 (I,K,LP,JV)=S0 (I,K,LP,JV)-F0 (I,L,JV) + SZ (I,K,LP,JV)=ALF1Q(I) + + *(SZ(I,K,LP,JV)+3.*ALF(I)*SZZ(I,K,LP,JV)) + SZZ(I,K,LP,JV)=ALF4 (I)*SZZ(I,K,LP,JV) + SSXZ(I,K,LP,JV)=ALF1Q(I)*SSXZ(I,K,LP,JV) + SYZ(I,K,LP,JV)=ALF1Q(I)*SYZ(I,K,LP,JV) + SSX (I,K,LP,JV)=SSX (I,K,LP,JV)-FX (I,L,JV) + SY (I,K,LP,JV)=SY (I,K,LP,JV)-FY (I,L,JV) + SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)-FXX(I,L,JV) + SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)-FXY(I,L,JV) + SYY(I,K,LP,JV)=SYY(I,K,LP,JV)-FYY(I,L,JV) +C + ELSE +C + F0 (I,L,JV)=ALF (I)*(S0(I,K,L,JV) + + +ALF1(I) * (SZ(I,K,L,JV)+ALF2(I)*SZZ(I,K,L,JV)) ) + FZ (I,L,JV)=ALFQ(I)*(SZ(I,K,L,JV)+3.*ALF1(I)*SZZ(I,K,L,JV)) + FZZ(I,L,JV)=ALF3(I)*SZZ(I,K,L,JV) + FXZ(I,L,JV)=ALFQ(I)*SSXZ(I,K,L,JV) + FYZ(I,L,JV)=ALFQ(I)*SYZ(I,K,L,JV) + FX (I,L,JV)=ALF (I)*(SSX(I,K,L,JV)+ALF1(I)*SSXZ(I,K,L,JV)) + FY (I,L,JV)=ALF (I)*(SY(I,K,L,JV)+ALF1(I)*SYZ(I,K,L,JV)) + FXX(I,L,JV)=ALF (I)*SSXX(I,K,L,JV) + FXY(I,L,JV)=ALF (I)*SSXY(I,K,L,JV) + FYY(I,L,JV)=ALF (I)*SYY(I,K,L,JV) +C + S0 (I,K,L,JV)=S0 (I,K,L,JV)-F0(I,L,JV) + SZ (I,K,L,JV)=ALF1Q(I)*(SZ(I,K,L,JV)-3.*ALF(I)*SZZ(I,K,L,JV)) + SZZ(I,K,L,JV)=ALF4 (I)*SZZ(I,K,L,JV) + SSXZ(I,K,L,JV)=ALF1Q(I)*SSXZ(I,K,L,JV) + SYZ(I,K,L,JV)=ALF1Q(I)*SYZ(I,K,L,JV) + SSX (I,K,L,JV)=SSX (I,K,L,JV)-FX (I,L,JV) + SY (I,K,L,JV)=SY (I,K,L,JV)-FY (I,L,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)-FXX(I,L,JV) + SSXY(I,K,L,JV)=SSXY(I,K,L,JV)-FXY(I,L,JV) + SYY(I,K,L,JV)=SYY(I,K,L,JV)-FYY(I,L,JV) +C + ENDIF +C + 1110 CONTINUE + 111 CONTINUE +C + 11 CONTINUE +C +C puts the temporary moments Fi into appropriate neighboring boxes +C + DO 12 L=1,NIV-1 + LP=L+1 +C + DO 120 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN + SM(I,K,L)=SM(I,K,L)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,L) + ELSE + SM(I,K,LP)=SM(I,K,LP)+FM(I,L) + ALF(I)=FM(I,L)/SM(I,K,LP) + ENDIF +C + ALF1(I)=1.-ALF(I) + ALFQ(I)=ALF(I)*ALF(I) + ALF1Q(I)=ALF1(I)*ALF1(I) + ALF2(I)=ALF(I)*ALF1(I) + ALF3(I)=ALF1(I)-ALF(I) +C + 120 CONTINUE +C + DO 121 JV=1,NTRA + DO 1210 I=1,LON +C + IF(WGRI(I,K,L).LT.0.) THEN +C + TEMPTM=-ALF(I)*S0(I,K,L,JV)+ALF1(I)*F0(I,L,JV) + S0 (I,K,L,JV)=S0(I,K,L,JV)+F0(I,L,JV) + SZZ(I,K,L,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,L,JV) + + +5.*( ALF2(I)*(FZ(I,L,JV)-SZ(I,K,L,JV))+ALF3(I)*TEMPTM ) + SZ (I,K,L,JV)=ALF (I)*FZ (I,L,JV)+ALF1 (I)*SZ (I,K,L,JV) + + +3.*TEMPTM + SSXZ(I,K,L,JV)=ALF (I)*FXZ(I,L,JV)+ALF1 (I)*SSXZ(I,K,L,JV) + + +3.*(ALF1(I)*FX (I,L,JV)-ALF (I)*SSX (I,K,L,JV)) + SYZ(I,K,L,JV)=ALF (I)*FYZ(I,L,JV)+ALF1 (I)*SYZ(I,K,L,JV) + + +3.*(ALF1(I)*FY (I,L,JV)-ALF (I)*SY (I,K,L,JV)) + SSX (I,K,L,JV)=SSX (I,K,L,JV)+FX (I,L,JV) + SY (I,K,L,JV)=SY (I,K,L,JV)+FY (I,L,JV) + SSXX(I,K,L,JV)=SSXX(I,K,L,JV)+FXX(I,L,JV) + SSXY(I,K,L,JV)=SSXY(I,K,L,JV)+FXY(I,L,JV) + SYY(I,K,L,JV)=SYY(I,K,L,JV)+FYY(I,L,JV) +C + ELSE +C + TEMPTM=ALF(I)*S0(I,K,LP,JV)-ALF1(I)*F0(I,L,JV) + S0 (I,K,LP,JV)=S0(I,K,LP,JV)+F0(I,L,JV) + SZZ(I,K,LP,JV)=ALFQ(I)*FZZ(I,L,JV)+ALF1Q(I)*SZZ(I,K,LP,JV) + + +5.*( ALF2(I)*(SZ(I,K,LP,JV)-FZ(I,L,JV))-ALF3(I)*TEMPTM ) + SZ (I,K,LP,JV)=ALF (I)*FZ(I,L,JV)+ALF1(I)*SZ(I,K,LP,JV) + + +3.*TEMPTM + SSXZ(I,K,LP,JV)=ALF(I)*FXZ(I,L,JV)+ALF1(I)*SSXZ(I,K,LP,JV) + + +3.*(ALF(I)*SSX(I,K,LP,JV)-ALF1(I)*FX(I,L,JV)) + SYZ(I,K,LP,JV)=ALF(I)*FYZ(I,L,JV)+ALF1(I)*SYZ(I,K,LP,JV) + + +3.*(ALF(I)*SY(I,K,LP,JV)-ALF1(I)*FY(I,L,JV)) + SSX (I,K,LP,JV)=SSX (I,K,LP,JV)+FX (I,L,JV) + SY (I,K,LP,JV)=SY (I,K,LP,JV)+FY (I,L,JV) + SSXX(I,K,LP,JV)=SSXX(I,K,LP,JV)+FXX(I,L,JV) + SSXY(I,K,LP,JV)=SSXY(I,K,LP,JV)+FXY(I,L,JV) + SYY(I,K,LP,JV)=SYY(I,K,LP,JV)+FYY(I,L,JV) +C + ENDIF +C + 1210 CONTINUE + 121 CONTINUE +C + 12 CONTINUE +C +C fin de la boucle principale sur les latitudes +C + 1 CONTINUE +C + DO l = 1,llm + DO j = 1,jjp1 + SM(iip1,j,l) = SM(1,j,l) + S0(iip1,j,l,ntra) = S0(1,j,l,ntra) + SSX(iip1,j,l,ntra) = SSX(1,j,l,ntra) + SY(iip1,j,l,ntra) = SY(1,j,l,ntra) + SZ(iip1,j,l,ntra) = SZ(1,j,l,ntra) + ENDDO + ENDDO +c C------------------------------------------------------------- +C *** Test : diag de la qqtite totale de tarceur +C dans l'atmosphere avant l'advection en z + DO l = 1,llm + DO j = 1,jjp1 + DO i = 1,iim + sqf = sqf + S0(i,j,l,ntra) + ENDDO + ENDDO + ENDDO + PRINT*,'-------- DIAG DANS ADVZ - SORTIE ---------' + PRINT*,'sqf=', sqf + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/allocate_field_mod.f90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/allocate_field_mod.f90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/allocate_field_mod.f90 (revision 1632) @@ -0,0 +1,739 @@ +MODULE allocate_field + + INTERFACE allocate_u + MODULE PROCEDURE allocate1d_u1d,allocate2d_u1d,allocate3d_u1d + END INTERFACE allocate_u + + INTERFACE switch_u + MODULE PROCEDURE switch1d_u1d,switch2d_u1d,switch3d_u1d + END INTERFACE switch_u + + INTERFACE switch_v + MODULE PROCEDURE switch1d_v1d,switch2d_v1d,switch3d_v1d + END INTERFACE switch_v + + INTERFACE allocate_v + MODULE PROCEDURE allocate1d_v1d,allocate2d_v1d,allocate3d_v1d + END INTERFACE allocate_v + + INTERFACE allocate2d_u + MODULE PROCEDURE allocate1d_u2d,allocate2d_u2d,allocate3d_u2d + END INTERFACE allocate2d_u + + INTERFACE allocate2d_v + MODULE PROCEDURE allocate1d_v2d,allocate2d_v2d,allocate3d_v2d + END INTERFACE allocate2d_v + + INTERFACE switch2d_u + MODULE PROCEDURE switch1d_u2d,switch2d_u2d,switch3d_u2d + END INTERFACE switch2d_u + + INTERFACE switch2d_v + MODULE PROCEDURE switch1d_v2d,switch2d_v2d,switch3d_v2d + END INTERFACE switch2D_v + + REAL :: nan + +CONTAINS + + SUBROUTINE Init_nan + IMPLICIT NONE + REAL*8 :: rnan + INTEGER :: inan(2) + EQUIVALENCE(rnan,inan) + + inan(1)=2147483647 + inan(2)=2147483647 + + nan=rnan + + END SUBROUTINE Init_nan + + SUBROUTINE allocate1d_u1d(field,d) + USE parallel + IMPLICIT NONE + REAL,POINTER :: field(:) + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_u:d%ije_u)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate1d_u1d + + + SUBROUTINE allocate2d_u1d(field,dim1,d) + USE parallel + IMPLICIT NONE + REAL,POINTER :: field(:,:) + INTEGER :: dim1 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_u:d%ije_u,dim1)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate2d_u1d + + SUBROUTINE allocate3d_u1d(field,dim1,dim2,d) + USE parallel + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + INTEGER :: dim1,dim2 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_u:d%ije_u,dim1,dim2)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate3d_u1d + + + + SUBROUTINE allocate1d_v1d(field,d) + USE parallel + IMPLICIT NONE + REAL,POINTER :: field(:) + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_v:d%ije_v)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate1d_v1d + + + SUBROUTINE allocate2d_v1d(field,dim1,d) + USE parallel + IMPLICIT NONE + REAL,POINTER :: field(:,:) + INTEGER :: dim1 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_v:d%ije_v,dim1)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate2d_v1d + + SUBROUTINE allocate3d_v1d(field,dim1,dim2,d) + USE parallel + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + INTEGER :: dim1,dim2 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(d%ijb_v:d%ije_v,dim1,dim2)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate3d_v1d + + + + + + + + + + SUBROUTINE allocate1d_u2d(field,d) + USE parallel + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_u:d%jje_u)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate1d_u2d + + + SUBROUTINE allocate2d_u2d(field,dim1,d) + USE parallel + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + INTEGER :: dim1 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate2d_u2d + + SUBROUTINE allocate3d_u2d(field,dim1,dim2,d) + USE parallel + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:,:,:) + INTEGER :: dim1,dim2 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_u:d%jje_u,dim1,dim2)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate3d_u2d + + + + SUBROUTINE allocate1d_v2d(field,d) + USE parallel + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_v:d%jje_v)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate1d_v2d + + + SUBROUTINE allocate2d_v2d(field,dim1,d) + USE parallel + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + INTEGER :: dim1 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate2d_v2d + + SUBROUTINE allocate3d_v2d(field,dim1,dim2,d) + USE parallel + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:,:,:) + INTEGER :: dim1,dim2 + TYPE(distrib),INTENT(IN) :: d + +!$OMP BARRIER +!$OMP MASTER + IF (ASSOCIATED(field)) DEALLOCATE(field) + ALLOCATE(field(iip1,d%jjb_v:d%jje_v,dim1,dim2)) +!$OMP END MASTER +!$OMP BARRIER + + END SUBROUTINE allocate3d_v2d + + + + + + + + + + + + + + + + + + + + SUBROUTINE switch1d_u1d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u)) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + + CALL barrier + END SUBROUTINE switch1d_u1d + + SUBROUTINE switch2d_u1d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch2d_u1d + + SUBROUTINE switch3d_u1d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_u:new_dist%ije_u,size(field,2),size(field,3))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch3d_u1d + + + + + SUBROUTINE switch1d_v1d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v)) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + + CALL barrier + END SUBROUTINE switch1d_v1d + + SUBROUTINE switch2d_v1d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch2d_v1d + + SUBROUTINE switch3d_v1d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(new_dist%ijb_v:new_dist%ije_v,size(field,2),size(field,3))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch3d_v1d + + + + + + + + + + + + + SUBROUTINE switch1d_u2d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u)) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch1d_u2d + + SUBROUTINE switch2d_u2d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch2d_u2d + + SUBROUTINE switch3d_u2d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_u:new_dist%jje_u,size(field,3),size(field,4))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_u(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch3d_u2d + + + + + SUBROUTINE switch1d_v2d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v)) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + CALL barrier + + END SUBROUTINE switch1d_v2d + + SUBROUTINE switch2d_v2d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + + CALL barrier + END SUBROUTINE switch2d_v2d + + SUBROUTINE switch3d_v2d(field,old_dist,new_dist,up,down) + USE parallel + USE mod_hallo + USE dimensions + IMPLICIT NONE + REAL,POINTER :: field(:,:,:,:) + TYPE(distrib),INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER, OPTIONAL,INTENT(IN) :: up + INTEGER, OPTIONAL,INTENT(IN) :: down + + REAL,POINTER,SAVE :: new_field(:,:,:,:) + TYPE(request) :: req + + !$OMP BARRIER + !$OMP MASTER + ALLOCATE(new_field(iip1,new_dist%jjb_v:new_dist%jje_v,size(field,3),size(field,4))) + new_field=nan + !$OMP END MASTER + !$OMP BARRIER + CALL Register_SwapField2d_v(field,new_field,new_dist,req,old_dist=old_dist,up=up,down=down) + + CALL SendRequest(req) + + !$OMP BARRIER + CALL WaitRequest(req) + !$OMP BARRIER + + !$OMP MASTER + DEALLOCATE(field) + field=>new_field + !$OMP END MASTER + !$OMP BARRIER + + CALL barrier + END SUBROUTINE switch3d_v2d + +END MODULE allocate_field + + + + Index: /LMDZ5/trunk/libf/dyn3dmem/bands.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/bands.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/bands.F90 (revision 1632) @@ -0,0 +1,482 @@ +! +! $Id: bands.F90 1279 2009-12-10 09:02:56Z fairhead $ +! + module Bands + USE parallel + integer, parameter :: bands_caldyn=1 + integer, parameter :: bands_vanleer=2 + integer, parameter :: bands_dissip=3 + + INTEGER,dimension(:),allocatable :: jj_Nb_Caldyn + INTEGER,dimension(:),allocatable :: jj_Nb_vanleer + INTEGER,dimension(:),allocatable :: jj_Nb_vanleer2 + INTEGER,dimension(:),allocatable :: jj_Nb_dissip + INTEGER,dimension(:),allocatable :: jj_Nb_physic + INTEGER,dimension(:),allocatable :: jj_Nb_physic_bis + + TYPE(distrib),SAVE,TARGET :: distrib_Caldyn + TYPE(distrib),SAVE,TARGET :: distrib_vanleer + TYPE(distrib),SAVE,TARGET :: distrib_vanleer2 + TYPE(distrib),SAVE,TARGET :: distrib_dissip + TYPE(distrib),SAVE,TARGET :: distrib_physic + TYPE(distrib),SAVE,TARGET :: distrib_physic_bis + + INTEGER,dimension(:),allocatable :: distrib_phys + + contains + + subroutine AllocateBands + use parallel + implicit none + + allocate(jj_Nb_Caldyn(0:MPI_Size-1)) + allocate(jj_Nb_vanleer(0:MPI_Size-1)) + allocate(jj_Nb_vanleer2(0:MPI_Size-1)) + allocate(jj_Nb_dissip(0:MPI_Size-1)) + allocate(jj_Nb_physic(0:MPI_Size-1)) + allocate(jj_Nb_physic_bis(0:MPI_Size-1)) + allocate(distrib_phys(0:MPI_Size-1)) + + end subroutine AllocateBands + + subroutine Read_distrib + use parallel + implicit none + + include "dimensions.h" + integer :: i,j + character (len=4) :: siim,sjjm,sllm,sproc + character (len=255) :: filename + integer :: unit_number=10 + integer :: ierr + + call AllocateBands + write(siim,'(i3)') iim + write(sjjm,'(i3)') jjm + write(sllm,'(i3)') llm + write(sproc,'(i3)') mpi_size + filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_' & + //TRIM(ADJUSTL(sproc))//'prc.dat' + + OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='old',FORM='formatted',IOSTAT=ierr) + + if (ierr==0) then + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_caldyn(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_vanleer(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,jj_nb_dissip(i) + enddo + + do i=0,mpi_size-1 + read (unit_number,*) j,distrib_phys(i) + enddo + + CLOSE(unit_number) + + else + do i=0,mpi_size-1 + jj_nb_caldyn(i)=(jjm+1)/mpi_size + if (ivalue(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + if (jj_nb_caldyn(max_proc)>3) then + if (timer_iteration(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc)<=1 ) then + jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1 + jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1 + exit + else + if (timer_average(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) & + -timer_delta(jj_nb_caldyn(min_proc)+1,timer_caldyn,min_proc) < maxvalue) then + jj_nb_caldyn(min_proc)=jj_nb_caldyn(min_proc)+1 + jj_nb_caldyn(max_proc)=jj_nb_caldyn(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + CALL create_distrib(jj_nb_caldyn,new_dist) + + end subroutine AdjustBands_caldyn + + subroutine AdjustBands_vanleer(new_dist) + use times + use parallel + implicit none + TYPE(distrib),INTENT(INOUT) :: new_dist + + real :: minvalue,maxvalue + integer :: min_proc,max_proc + integer :: i,j + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: index + real :: tmpvalue + integer :: tmpindex + + allocate(value(0:mpi_size-1)) + allocate(index(0:mpi_size-1)) + + + call allgather_timer_average + + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_vanleer(i),timer_vanleer,i) + index(i)=i + enddo + + do i=0,mpi_size-2 + do j=i+1,mpi_size-1 + if (value(i)>value(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + + if (jj_nb_vanleer(max_proc)>3) then + if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc)==0. .or. & + timer_average(jj_nb_vanleer(max_proc)-1,timer_vanleer,max_proc)==0.) then + jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1 + jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1 + exit + else + if (timer_average(jj_nb_vanleer(min_proc)+1,timer_vanleer,min_proc) < maxvalue) then + jj_nb_vanleer(min_proc)=jj_nb_vanleer(min_proc)+1 + jj_nb_vanleer(max_proc)=jj_nb_vanleer(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + + CALL create_distrib(jj_nb_vanleer,new_dist) + + end subroutine AdjustBands_vanleer + + subroutine AdjustBands_dissip(new_dist) + use times + use parallel + implicit none + TYPE(distrib),INTENT(INOUT) :: new_dist + + real :: minvalue,maxvalue + integer :: min_proc,max_proc + integer :: i,j + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: index + real :: tmpvalue + integer :: tmpindex + + allocate(value(0:mpi_size-1)) + allocate(index(0:mpi_size-1)) + + + call allgather_timer_average + + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_dissip(i),timer_dissip,i) + index(i)=i + enddo + + do i=0,mpi_size-2 + do j=i+1,mpi_size-1 + if (value(i)>value(j)) then + tmpvalue=value(i) + value(i)=value(j) + value(j)=tmpvalue + + tmpindex=index(i) + index(i)=index(j) + index(j)=tmpindex + endif + enddo + enddo + + maxvalue=value(mpi_size-1) + max_proc=index(mpi_size-1) + + do i=0,mpi_size-2 + minvalue=value(i) + min_proc=index(i) + + if (jj_nb_dissip(max_proc)>3) then + if (timer_iteration(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc)<=1) then + jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1 + jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1 + exit + else + if (timer_average(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) & + - timer_delta(jj_nb_dissip(min_proc)+1,timer_dissip,min_proc) < maxvalue) then + jj_nb_dissip(min_proc)=jj_nb_dissip(min_proc)+1 + jj_nb_dissip(max_proc)=jj_nb_dissip(max_proc)-1 + exit + endif + endif + endif + enddo + + deallocate(value) + deallocate(index) + + CALL create_distrib(jj_nb_dissip,new_dist) + + end subroutine AdjustBands_dissip + + subroutine AdjustBands_physic + use times +#ifdef CPP_EARTH +! Ehouarn: what follows is only related to // physics; for now only for Earth + USE mod_phys_lmdz_para, only : klon_mpi_para_nb +#endif + USE parallel + implicit none + + integer :: i,Index + real,allocatable,dimension(:) :: value + integer,allocatable,dimension(:) :: Inc + real :: medium + integer :: NbTot,sgn + + allocate(value(0:mpi_size-1)) + allocate(Inc(0:mpi_size-1)) + + + call allgather_timer_average + + medium=0 + do i=0,mpi_size-1 + value(i)=timer_average(jj_nb_physic(i),timer_physic,i) + medium=medium+value(i) + enddo + + medium=medium/mpi_size + NbTot=0 +#ifdef CPP_EARTH +! Ehouarn: what follows is only related to // physics; for now only for Earth + do i=0,mpi_size-1 + Inc(i)=nint(klon_mpi_para_nb(i)*(medium-value(i))/value(i)) + NbTot=NbTot+Inc(i) + enddo + + if (NbTot>=0) then + Sgn=1 + else + Sgn=-1 + NbTot=-NbTot + endif + + Index=0 + do i=1,NbTot + Inc(Index)=Inc(Index)-Sgn + Index=Index+1 + if (Index>mpi_size-1) Index=0 + enddo + + do i=0,mpi_size-1 + distrib_phys(i)=klon_mpi_para_nb(i)+inc(i) + enddo +#endif + + end subroutine AdjustBands_physic + + subroutine WriteBands + USE parallel + implicit none + include "dimensions.h" + + integer :: i,j + character (len=4) :: siim,sjjm,sllm,sproc + character (len=255) :: filename + integer :: unit_number=10 + integer :: ierr + + write(siim,'(i3)') iim + write(sjjm,'(i3)') jjm + write(sllm,'(i3)') llm + write(sproc,'(i3)') mpi_size + + filename='Bands_'//TRIM(ADJUSTL(siim))//'x'//TRIM(ADJUSTL(sjjm))//'x'//TRIM(ADJUSTL(sllm))//'_' & + //TRIM(ADJUSTL(sproc))//'prc.dat' + + OPEN(UNIT=unit_number,FILE=trim(filename),STATUS='replace',FORM='formatted',IOSTAT=ierr) + + if (ierr==0) then + +! write (unit_number,*) '*** Bandes caldyn ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_caldyn(i) + enddo + +! write (unit_number,*) '*** Bandes vanleer ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_vanleer(i) + enddo + +! write (unit_number,*) '*** Bandes dissip ***' + do i=0,mpi_size-1 + write (unit_number,*) i,jj_nb_dissip(i) + enddo + + do i=0,mpi_size-1 + write (unit_number,*) i,distrib_phys(i) + enddo + + CLOSE(unit_number) + else + print *,'probleme lors de l ecriture des bandes' + endif + + end subroutine WriteBands + + end module Bands + + Index: /LMDZ5/trunk/libf/dyn3dmem/bernoui.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/bernoui.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/bernoui.F (revision 1632) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE bernoui (ngrid,nlay,pphi,pecin,pbern) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul de la fonction de Bernouilli aux niveaux s ..... +c phi et ecin sont des arguments d'entree pour le s-pg ....... +c bern est un argument de sortie pour le s-pg ...... +c +c fonction de Bernouilli = bern = filtre de( geopotentiel + +c energ.cinet.) +c +c======================================================================= +c +c----------------------------------------------------------------------- +c Decalrations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +c +c Arguments: +c ---------- +c + INTEGER nlay,ngrid + REAL pphi(ngrid*nlay),pecin(ngrid*nlay),pbern(ngrid*nlay) +c +c Local: +c ------ +c + INTEGER ijl +c +c----------------------------------------------------------------------- +c calcul de Bernouilli: +c --------------------- +c + DO 4 ijl = 1,ngrid*nlay + pbern( ijl ) = pphi( ijl ) + pecin( ijl ) + 4 CONTINUE +c +c----------------------------------------------------------------------- +c filtre: +c ------- +c + CALL filtreg( pbern, jjp1, llm, 2,1, .true., 1 ) +c +c----------------------------------------------------------------------- + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/bernoui_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/bernoui_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/bernoui_loc.F (revision 1632) @@ -0,0 +1,77 @@ + SUBROUTINE bernoui_loc (ngrid,nlay,pphi,pecin,pbern) + USE parallel + USE mod_filtreg_p + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul de la fonction de Bernouilli aux niveaux s ..... +c phi et ecin sont des arguments d'entree pour le s-pg ....... +c bern est un argument de sortie pour le s-pg ...... +c +c fonction de Bernouilli = bern = filtre de( geopotentiel + +c energ.cinet.) +c +c======================================================================= +c +c----------------------------------------------------------------------- +c Decalrations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +c +c Arguments: +c ---------- +c + INTEGER nlay,ngrid + REAL pphi(ijb_u:ije_u,nlay),pecin(ijb_u:ije_u,nlay) + REAL pbern(ijb_u:ije_u,nlay) +c +c Local: +c ------ +c + INTEGER ij,l,ijb,ije,jjb,jje +c +c----------------------------------------------------------------------- +c calcul de Bernouilli: +c --------------------- +c + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + DO 4 ij = ijb,ije + pbern( ij,l ) = pphi( ij,l ) + pecin( ij,l ) + 4 CONTINUE + + ENDDO +c$OMP END DO NOWAIT +c +c----------------------------------------------------------------------- +c filtre: +c ------- +c + + + CALL filtreg_p( pbern,jjb_u,jje_u,jjb,jje, jjp1, llm, + & 2,1, .true., 1 ) +c +c----------------------------------------------------------------------- + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/bilan_dyn_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/bilan_dyn_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/bilan_dyn_loc.F (revision 1632) @@ -0,0 +1,839 @@ +! +! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! + SUBROUTINE bilan_dyn_loc (ntrac,dt_app,dt_cum, + s ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac) + +c AFAIRE +c Prevoir en champ nq+1 le diagnostique de l'energie +c en faisant Qzon=Cv T + L * ... +c vQ..A=Cp T + L * ... + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE parallel + USE mod_hallo + use misc_mod + use write_field + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" +#include "temps.h" +#include "iniprint.h" + +c==================================================================== +c +c Sous-programme consacre à des diagnostics dynamiques de base +c +c +c De facon generale, les moyennes des scalaires Q sont ponderees par +c la masse. +c +c Les flux de masse sont eux simplement moyennes. +c +c==================================================================== + +c Arguments : +c =========== + + integer ntrac + real dt_app,dt_cum + real ps(iip1,jjb_u:jje_u) + real masse(iip1,jjb_u:jje_u,llm),pk(iip1,jjb_u:jje_u,llm) + real flux_u(iip1,jjb_u:jje_u,llm) + real flux_v(iip1,jjb_v:jje_v,llm) + real teta(iip1,jjb_u:jje_u,llm) + real phi(iip1,jjb_u:jje_u,llm) + real ucov(iip1,jjb_u:jje_u,llm) + real vcov(iip1,jjb_v:jje_v,llm) + real trac(iip1,jjb_u:jje_u,llm,ntrac) + +c Local : +c ======= + + integer,SAVE :: icum,ncum +!$OMP THREADPRIVATE(icum,ncum) + LOGICAL,SAVE :: first=.TRUE. +!$OMP THREADPRIVATE(first) + + real zz,zqy + REAl,SAVE,ALLOCATABLE :: zfactv(:,:) + + INTEGER,PARAMETER :: nQ=7 + + +cym character*6 nom(nQ) +cym character*6 unites(nQ) + character(len=6),save :: nom(nQ) + character(len=6),save :: unites(nQ) + + character(len=10) file + integer ifile + parameter (ifile=4) + + integer,PARAMETER :: itemp=1,igeop=2,iecin=3,iang=4,iu=5 + INTEGER,PARAMETER :: iovap=6,iun=7 + integer,PARAMETER :: i_sortie=1 + + real,SAVE :: time=0. + integer,SAVE :: itau=0. +!$OMP THREADPRIVATE(time,itau) + + real ww + +c variables dynamiques intermédiaires + REAL,SAVE,ALLOCATABLE :: vcont(:,:,:),ucont(:,:,:) + REAL,SAVE,ALLOCATABLE :: ang(:,:,:),unat(:,:,:) + REAL,SAVE,ALLOCATABLE :: massebx(:,:,:),masseby(:,:,:) + REAL,SAVE,ALLOCATABLE :: vorpot(:,:,:) + REAL,SAVE,ALLOCATABLE :: w(:,:,:),ecin(:,:,:),convm(:,:,:) + REAL,SAVE,ALLOCATABLE :: bern(:,:,:) + +c champ contenant les scalaires advectés. + real,SAVE,ALLOCATABLE :: Q(:,:,:,:) + +c champs cumulés + real,SAVE,ALLOCATABLE :: ps_cum(:,:) + real,SAVE,ALLOCATABLE :: masse_cum(:,:,:) + real,SAVE,ALLOCATABLE :: flux_u_cum(:,:,:) + real,SAVE,ALLOCATABLE :: flux_v_cum(:,:,:) + real,SAVE,ALLOCATABLE :: Q_cum(:,:,:,:) + real,SAVE,ALLOCATABLE :: flux_uQ_cum(:,:,:,:) + real,SAVE,ALLOCATABLE :: flux_vQ_cum(:,:,:,:) + real,SAVE,ALLOCATABLE :: flux_wQ_cum(:,:,:,:) + real,SAVE,ALLOCATABLE :: dQ(:,:,:,:) + + +c champs de tansport en moyenne zonale + integer ntr,itr + parameter (ntr=5) + +cym character*10 znom(ntr,nQ) +cym character*20 znoml(ntr,nQ) +cym character*10 zunites(ntr,nQ) + character*10,save :: znom(ntr,nQ) + character*20,save :: znoml(ntr,nQ) + character*10,save :: zunites(ntr,nQ) + + INTEGER,PARAMETER :: iave=1,itot=2,immc=3,itrs=4,istn=5 + + character*3 ctrs(ntr) + data ctrs/' ','TOT','MMC','TRS','STN'/ + + real,SAVE,ALLOCATABLE :: zvQ(:,:,:,:),zvQtmp(:,:) + real,SAVE,ALLOCATABLE :: zavQ(:,:,:),psiQ(:,:,:) + real,SAVE,ALLOCATABLE :: zmasse(:,:),zamasse(:) + + real,SAVE,ALLOCATABLE :: zv(:,:),psi(:,:) + + integer i,j,l,iQ + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + character*10 infile + + integer fileid + integer thoriid, zvertiid + save fileid + + INTEGER,SAVE,ALLOCATABLE :: ndex3d(:) + +C Variables locales +C + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer ii,jj + integer zan, dayref +C + real,SAVE,ALLOCATABLE :: rlong(:),rlatg(:) + integer :: jjb,jje,jjn,ijb,ije + type(Request) :: Req + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(1) :: ddid + INTEGER,DIMENSION(1) :: dsg + INTEGER,DIMENSION(1) :: dsl + INTEGER,DIMENSION(1) :: dpf + INTEGER,DIMENSION(1) :: dpl + INTEGER,DIMENSION(1) :: dhs + INTEGER,DIMENSION(1) :: dhe + + INTEGER :: bilan_dyn_domain_id + + +c===================================================================== +c Initialisation +c===================================================================== + if (adjust) return + + time=time+dt_app + itau=itau+1 + + if (first) then +!$OMP BARRIER +!$OMP MASTER + ALLOCATE(zfactv(jjb_v:jje_v,llm)) + ALLOCATE(vcont(iip1,jjb_v:jje_v,llm)) + ALLOCATE(ucont(iip1,jjb_u:jje_u,llm)) + ALLOCATE(ang(iip1,jjb_u:jje_u,llm)) + ALLOCATE(unat(iip1,jjb_u:jje_u,llm)) + ALLOCATE(massebx(iip1,jjb_u:jje_u,llm)) + ALLOCATE(masseby(iip1,jjb_v:jje_v,llm)) + ALLOCATE(vorpot(iip1,jjb_v:jje_v,llm)) + ALLOCATE(w(iip1,jjb_u:jje_u,llm)) + ALLOCATE(ecin(iip1,jjb_u:jje_u,llm)) + ALLOCATE(convm(iip1,jjb_u:jje_u,llm)) + ALLOCATE(bern(iip1,jjb_u:jje_u,llm)) + ALLOCATE(Q(iip1,jjb_u:jje_u,llm,nQ)) + ALLOCATE(ps_cum(iip1,jjb_u:jje_u)) + ALLOCATE(masse_cum(iip1,jjb_u:jje_u,llm)) + ALLOCATE(flux_u_cum(iip1,jjb_u:jje_u,llm)) + ALLOCATE(flux_v_cum(iip1,jjb_v:jje_v,llm)) + ALLOCATE(Q_cum(iip1,jjb_u:jje_u,llm,nQ)) + ALLOCATE(flux_uQ_cum(iip1,jjb_u:jje_u,llm,nQ)) + ALLOCATE(flux_vQ_cum(iip1,jjb_v:jje_v,llm,nQ)) + ALLOCATE(flux_wQ_cum(iip1,jjb_u:jje_u,llm,nQ)) + ALLOCATE(dQ(iip1,jjb_u:jje_u,llm,nQ)) + ALLOCATE(zvQ(jjb_v:jje_v,llm,ntr,nQ)) + ALLOCATE(zvQtmp(jjb_v:jje_v,llm)) + ALLOCATE(zavQ(jjb_v:jje_v,ntr,nQ)) + ALLOCATE(psiQ(jjb_v:jje_v,llm+1,nQ)) + ALLOCATE(zmasse(jjb_v:jje_v,llm)) + ALLOCATE(zamasse(jjb_v:jje_v)) + ALLOCATE(zv(jjb_v:jje_v,llm)) + ALLOCATE(psi(jjb_v:jje_v,llm+1)) + ALLOCATE(ndex3d(jjb_v:jje_v*llm)) + ndex3d=0 + ALLOCATE(rlong(jjb_v:jje_v)) + ALLOCATE(rlatg(jjb_v:jje_v)) + +!$OMP END MASTER +!$OMP BARRIER + icum=0 +c initialisation des fichiers + first=.false. +c ncum est la frequence de stokage en pas de temps + ncum=dt_cum/dt_app + if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then + WRITE(lunout,*) + . 'Pb : le pas de cumule doit etre multiple du pas' + WRITE(lunout,*)'dt_app=',dt_app + WRITE(lunout,*)'dt_cum=',dt_cum + stop + endif + +!$OMP MASTER + nom(itemp)='T' + nom(igeop)='gz' + nom(iecin)='K' + nom(iang)='ang' + nom(iu)='u' + nom(iovap)='ovap' + nom(iun)='un' + + unites(itemp)='K' + unites(igeop)='m2/s2' + unites(iecin)='m2/s2' + unites(iang)='ang' + unites(iu)='m/s' + unites(iovap)='kg/kg' + unites(iun)='un' + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + infile='dynzon' + + zan = annee_ref + dayref = day_ref + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + rlong=0. + rlatg=rlatv*180./pi + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + IF (pole_sud) THEN + jjn=jj_nb-1 + jje=jj_end-1 + ENDIF + + ddid=(/ 2 /) + dsg=(/ jjm /) + dsl=(/ jjn /) + dpf=(/ jjb /) + dpl=(/ jje /) + dhs=(/ 0 /) + dhe=(/ 0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',bilan_dyn_domain_id) + + call histbeg(trim(infile), + . 1, rlong(jjb:jje), jjn, rlatg(jjb:jje), + . 1, 1, 1, jjn, + . tau0, zjulian, dt_cum, thoriid, fileid, + . bilan_dyn_domain_id) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', + . llm, presnivs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder + do iQ=1,nQ + do itr=1,ntr + if(itr.eq.1) then + znom(itr,iQ)=nom(iQ) + znoml(itr,iQ)=nom(iQ) + zunites(itr,iQ)=unites(iQ) + else + znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ) + znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr) + zunites(itr,iQ)='m/s * '//unites(iQ) + endif + enddo + enddo + +c Declarations des champs avec dimension verticale +c print*,'1HISTDEF' + do iQ=1,nQ + do itr=1,ntr + IF (prt_level > 5) + . WRITE(lunout,*)'var ',itr,iQ + . ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ) + call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo +c Declarations pour les fonctions de courant +c print*,'2HISTDEF' + call histdef(fileid,'psi'//nom(iQ) + . ,'stream fn. '//znoml(itot,iQ), + . zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + + +c Declarations pour les champs de transport d'air +c print*,'3HISTDEF' + call histdef(fileid, 'masse', 'masse', + . 'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) + call histdef(fileid, 'v', 'v', + . 'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) +c Declarations pour les fonctions de courant +c print*,'4HISTDEF' + call histdef(fileid,'psi','stream fn. MMC ','mega t/s', + . 1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + + +c Declaration des champs 1D de transport en latitude +c print*,'5HISTDEF' + do iQ=1,nQ + do itr=2,ntr + call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + enddo + + +c print*,'8HISTDEF' + CALL histend(fileid) + +!$OMP END MASTER + endif + + +c===================================================================== +c Calcul des champs dynamiques +c ---------------------------- + + jjb=jj_begin + jje=jj_end + +c énergie cinétique +! ucont(:,jjb:jje,:)=0 + + call Register_Hallo_u(ucov,llm,1,1,1,1,Req) + call Register_Hallo_v(vcov,llm,1,1,1,1,Req) + call SendRequest(Req) +c$OMP BARRIER + call WaitRequest(Req) + + CALL covcont_loc(llm,ucov,vcov,ucont,vcont) + CALL enercin_loc(vcov,ucov,vcont,ucont,ecin) + +c moment cinétique +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje) + unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje) + enddo +!$OMP END DO NOWAIT + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + Q(:,jjb:jje,l,itemp)=teta(:,jjb:jje,l)*pk(:,jjb:jje,l)/cpp + Q(:,jjb:jje,l,igeop)=phi(:,jjb:jje,l) + Q(:,jjb:jje,l,iecin)=ecin(:,jjb:jje,l) + Q(:,jjb:jje,l,iang)=ang(:,jjb:jje,l) + Q(:,jjb:jje,l,iu)=unat(:,jjb:jje,l) + Q(:,jjb:jje,l,iovap)=trac(:,jjb:jje,l,1) + Q(:,jjb:jje,l,iun)=1. + ENDDO +!$OMP END DO NOWAIT + +c===================================================================== +c Cumul +c===================================================================== +c + if(icum.EQ.0) then + jjb=jj_begin + jje=jj_end + +!$OMP MASTER + ps_cum(:,jjb:jje)=0. +!$OMP END MASTER + + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + masse_cum(:,jjb:jje,l)=0. + flux_u_cum(:,jjb:jje,l)=0. + Q_cum(:,jjb:jje,:,l)=0. + flux_uQ_cum(:,jjb:jje,l,:)=0. + flux_v_cum(:,jjb:jje,l)=0. + if (pole_sud) jje=jj_end-1 + flux_v_cum(:,jjb:jje,l)=0. + flux_vQ_cum(:,jjb:jje,l,:)=0. + ENDDO +!$OMP END DO NOWAIT + endif + + IF (prt_level > 5) + . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1 + icum=icum+1 + +c accumulation des flux de masse horizontaux + jjb=jj_begin + jje=jj_end + +!$OMP MASTER + ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje) +!$OMP END MASTER + + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + masse_cum(:,jjb:jje,:)=masse_cum(:,jjb:jje,:)+masse(:,jjb:jje,:) + flux_u_cum(:,jjb:jje,:)=flux_u_cum(:,jjb:jje,:) + . +flux_u(:,jjb:jje,:) + ENDDO +!$OMP END DO NOWAIT + + if (pole_sud) jje=jj_end-1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + flux_v_cum(:,jjb:jje,:)=flux_v_cum(:,jjb:jje,:) + . +flux_v(:,jjb:jje,:) + ENDDO +!$OMP END DO NOWAIT + + jjb=jj_begin + jje=jj_end + + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + Q_cum(:,jjb:jje,:,iQ)=Q_cum(:,jjb:jje,:,iQ) + . +Q(:,jjb:jje,:,iQ)*masse(:,jjb:jje,:) + ENDDO +!$OMP END DO NOWAIT + enddo + +c===================================================================== +c FLUX ET TENDANCES +c===================================================================== + +c Flux longitudinal +c ----------------- + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iim + flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) + s +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ)) + enddo + flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ) + enddo + enddo +!$OMP END DO NOWAIT + enddo + +c flux méridien +c ------------- + do iQ=1,nQ + call Register_Hallo_u(Q(1,1,1,iQ),llm,0,1,1,0,Req) + enddo + call SendRequest(Req) +!$OMP BARRIER + call WaitRequest(Req) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iip1 + flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) + s +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ)) + enddo + enddo + enddo +!$OMP END DO NOWAIT + enddo + + +c tendances +c --------- + +c convergence horizontale + call Register_Hallo_u(flux_uQ_cum,llm,2,2,2,2,Req) + call Register_Hallo_v(flux_vQ_cum,llm,2,2,2,2,Req) + call SendRequest(Req) +!$OMP BARRIER + call WaitRequest(Req) + + call convflu_loc(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ) + +c calcul de la vitesse verticale + call Register_Hallo_u(flux_u_cum,llm,2,2,2,2,Req) + call Register_Hallo_v(flux_v_cum,llm,2,2,2,2,Req) + call SendRequest(Req) +!$OMP BARRIER + call WaitRequest(Req) + + call convmas_loc(flux_u_cum,flux_v_cum,convm) + CALL vitvert_loc(convm,w) +!$OMP BARRIER + + jjb=jj_begin + jje=jj_end + +! do iQ=1,nQ +! do l=1,llm-1 +! do j=jjb,jje +! do i=1,iip1 +! ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ)) +! dQ(i,j,l ,iQ)=dQ(i,j,l ,iQ)-ww +! dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww +! enddo +! enddo +! enddo +! enddo + + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + IF (l2) THEN + do j=jjb,jje + do i=1,iip1 + ww=-0.5*w(i,j,l)*(Q(i,j,l-1,iQ)+Q(i,j,l,iQ)) + dQ(i,j,l,iQ)=dQ(i,j,l,iQ)+ww + enddo + enddo + ENDIF + enddo +!$OMP ENDDO NOWAIT + enddo + IF (prt_level > 5) + . WRITE(lunout,*)'Apres les calculs fait a chaque pas' +c===================================================================== +c PAS DE TEMPS D'ECRITURE +c===================================================================== + if (icum.eq.ncum) then +c===================================================================== + + IF (prt_level > 5) + . WRITE(lunout,*)'Pas d ecriture' + + jjb=jj_begin + jje=jj_end + +c Normalisation + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + Q_cum(:,jjb:jje,l,iQ)=Q_cum(:,jjb:jje,l,iQ) + . /masse_cum(:,jjb:jje,l) + enddo +!$OMP ENDDO NOWAIT + enddo + + zz=1./REAL(ncum) + +!$OMP MASTER + ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz +!$OMP END MASTER + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + masse_cum(:,jjb:jje,l)=masse_cum(:,jjb:jje,l)*zz + flux_u_cum(:,jjb:jje,l)=flux_u_cum(:,jjb:jje,l)*zz + flux_uQ_cum(:,jjb:jje,l,:)=flux_uQ_cum(:,jjb:jje,l,:)*zz + dQ(:,jjb:jje,l,:)=dQ(:,jjb:jje,l,:)*zz + ENDDO +!$OMP ENDDO NOWAIT + + + IF (pole_sud) jje=jj_end-1 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + flux_v_cum(:,jjb:jje,l)=flux_v_cum(:,jjb:jje,l)*zz + flux_vQ_cum(:,jjb:jje,l,:)=flux_vQ_cum(:,jjb:jje,l,:)*zz + ENDDO +!$OMP ENDDO NOWAIT + + jjb=jj_begin + jje=jj_end + + +c A retravailler eventuellement +c division de dQ par la masse pour revenir aux bonnes grandeurs + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dQ(:,jjb:jje,l,iQ)=dQ(:,jjb:jje,l,iQ)/masse_cum(:,jjb:jje,l) + ENDDO +!$OMP ENDDO NOWAIT + enddo + +c===================================================================== +c Transport méridien +c===================================================================== + +c cumul zonal des masses des mailles +c ---------------------------------- + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + zv(jjb:jje,l)=0. + zmasse(jjb:jje,l)=0. + ENDDO +!$OMP ENDDO NOWAIT + + call Register_Hallo_u(masse_cum,llm,1,1,1,1,Req) + do iQ=1,nQ + call Register_Hallo_u(Q_cum(1,1,1,iQ),llm,0,1,1,0,Req) + enddo + + call SendRequest(Req) +!$OMP BARRIER + call WaitRequest(Req) + + call massbar_loc(masse_cum,massebx,masseby) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iim + zmasse(j,l)=zmasse(j,l)+masseby(i,j,l) + zv(j,l)=zv(j,l)+flux_v_cum(i,j,l) + enddo + zfactv(j,l)=cv(1,j)/zmasse(j,l) + enddo + enddo +!$OMP ENDDO NOWAIT + +c print*,'3OK' +c -------------------------------------------------------------- +c calcul de la moyenne zonale du transport : +c ------------------------------------------ +c +c -- +c TOT : la circulation totale [ vq ] +c +c - - +c MMC : mean meridional circulation [ v ] [ q ] +c +c ---- -- - - +c TRS : transitoires [ v'q'] = [ vq ] - [ v q ] +c +c - * - * - - - - +c STT : stationaires [ v q ] = [ v q ] - [ v ] [ q ] +c +c - - +c on utilise aussi l'intermediaire TMP : [ v q ] +c +c la variable zfactv transforme un transport meridien cumule +c en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte +c +c -------------------------------------------------------------- + + +c ---------------------------------------- +c Transport dans le plan latitude-altitude +c ---------------------------------------- + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + zvQ=0. + psiQ=0. + do iQ=1,nQ +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + zvQtmp(:,l)=0. + do j=jjb,jje +c print*,'j,l,iQ=',j,l,iQ +c Calcul des moyennes zonales du transort total et de zvQtmp + do i=1,iim + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) + s +flux_vQ_cum(i,j,l,iQ) + zqy= 0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ + s Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l)) + zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy + s /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l))) + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy + enddo +c print*,'aOK' +c Decomposition + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l) + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l) + zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l) + zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l) + zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l) + zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ) + enddo + enddo +!$OMP ENDDO NOWAIT +c fonction de courant meridienne pour la quantite Q +!$OMP BARRIER +!$OMP MASTER + do l=llm,1,-1 + do j=jjb,jje + psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ) + enddo + enddo +!$OMP END MASTER +!$OMP BARRIER + enddo + +c fonction de courant pour la circulation meridienne moyenne +!$OMP BARRIER +!$OMP MASTER + psi(jjb:jje,:)=0. + do l=llm,1,-1 + do j=jjb,jje + psi(j,l)=psi(j,l+1)+zv(j,l) + zv(j,l)=zv(j,l)*zfactv(j,l) + enddo + enddo +!$OMP END MASTER +!$OMP BARRIER + +c print*,'4OK' +c sorties proprement dites +!$OMP MASTER + if (i_sortie.eq.1) then + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) jje=jj_end-1 + if (pole_sud) jjn=jj_nb-1 + do iQ=1,nQ + do itr=1,ntr + call histwrite(fileid,znom(itr,iQ),itau, + s zvQ(jjb:jje,:,itr,iQ) + s ,jjn*llm,ndex3d) + enddo + call histwrite(fileid,'psi'//nom(iQ), + s itau,psiQ(jjb:jje,1:llm,iQ) + s ,jjn*llm,ndex3d) + enddo + + call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm) + s ,jjn*llm,ndex3d) + call histwrite(fileid,'v',itau,zv(jjb:jje,1:llm) + s ,jjn*llm,ndex3d) + psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9 + call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm), + s jjn*llm,ndex3d) + + endif + + +c ----------------- +c Moyenne verticale +c ----------------- + + zamasse(jjb:jje)=0. + do l=1,llm + zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l) + enddo + + zavQ(jjb:jje,:,:)=0. + do iQ=1,nQ + do itr=2,ntr + do l=1,llm + zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ) + s +zvQ(jjb:jje,l,itr,iQ) + s *zmasse(jjb:jje,l) + enddo + zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje) + call histwrite(fileid,'a'//znom(itr,iQ),itau, + s zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d) + enddo + enddo +!$OMP END MASTER +c on doit pouvoir tracer systematiquement la fonction de courant. + +c===================================================================== +c///////////////////////////////////////////////////////////////////// + icum=0 !/////////////////////////////////////// + endif ! icum.eq.ncum !/////////////////////////////////////// +c///////////////////////////////////////////////////////////////////// +c===================================================================== + + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/bilan_dyn_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/bilan_dyn_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/bilan_dyn_p.F (revision 1632) @@ -0,0 +1,717 @@ +! +! $Id: bilan_dyn_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! + SUBROUTINE bilan_dyn_p (ntrac,dt_app,dt_cum, + s ps,masse,pk,flux_u,flux_v,teta,phi,ucov,vcov,trac) + +c AFAIRE +c Prevoir en champ nq+1 le diagnostique de l'energie +c en faisant Qzon=Cv T + L * ... +c vQ..A=Cp T + L * ... + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE parallel + USE mod_hallo + use misc_mod + use write_field + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" +#include "temps.h" +#include "iniprint.h" + +c==================================================================== +c +c Sous-programme consacre à des diagnostics dynamiques de base +c +c +c De facon generale, les moyennes des scalaires Q sont ponderees par +c la masse. +c +c Les flux de masse sont eux simplement moyennes. +c +c==================================================================== + +c Arguments : +c =========== + + integer ntrac + real dt_app,dt_cum + real ps(iip1,jjp1) + real masse(iip1,jjp1,llm),pk(iip1,jjp1,llm) + real flux_u(iip1,jjp1,llm) + real flux_v(iip1,jjm,llm) + real teta(iip1,jjp1,llm) + real phi(iip1,jjp1,llm) + real ucov(iip1,jjp1,llm) + real vcov(iip1,jjm,llm) + real trac(iip1,jjp1,llm,ntrac) + +c Local : +c ======= + + integer icum,ncum + logical first + real zz,zqy,zfactv(jjm,llm) + + integer nQ + parameter (nQ=7) + + +cym character*6 nom(nQ) +cym character*6 unites(nQ) + character*6,save :: nom(nQ) + character*6,save :: unites(nQ) + + character*10 file + integer ifile + parameter (ifile=4) + + integer itemp,igeop,iecin,iang,iu,iovap,iun + integer i_sortie + + save first,icum,ncum + save itemp,igeop,iecin,iang,iu,iovap,iun + save i_sortie + + real time + integer itau + save time,itau + data time,itau/0.,0/ + + data first/.true./ + data itemp,igeop,iecin,iang,iu,iovap,iun/1,2,3,4,5,6,7/ + data i_sortie/1/ + + real ww + +c variables dynamiques intermédiaires + REAL vcont(iip1,jjm,llm),ucont(iip1,jjp1,llm) + REAL ang(iip1,jjp1,llm),unat(iip1,jjp1,llm) + REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm) + REAL vorpot(iip1,jjm,llm) + REAL w(iip1,jjp1,llm),ecin(iip1,jjp1,llm),convm(iip1,jjp1,llm) + REAL bern(iip1,jjp1,llm) + +c champ contenant les scalaires advectés. + real Q(iip1,jjp1,llm,nQ) + +c champs cumulés + real ps_cum(iip1,jjp1) + real masse_cum(iip1,jjp1,llm) + real flux_u_cum(iip1,jjp1,llm) + real flux_v_cum(iip1,jjm,llm) + real Q_cum(iip1,jjp1,llm,nQ) + real flux_uQ_cum(iip1,jjp1,llm,nQ) + real flux_vQ_cum(iip1,jjm,llm,nQ) + real flux_wQ_cum(iip1,jjp1,llm,nQ) + real dQ(iip1,jjp1,llm,nQ) + + save ps_cum,masse_cum,flux_u_cum,flux_v_cum + save Q_cum,flux_uQ_cum,flux_vQ_cum + +c champs de tansport en moyenne zonale + integer ntr,itr + parameter (ntr=5) + +cym character*10 znom(ntr,nQ) +cym character*20 znoml(ntr,nQ) +cym character*10 zunites(ntr,nQ) + character*10,save :: znom(ntr,nQ) + character*20,save :: znoml(ntr,nQ) + character*10,save :: zunites(ntr,nQ) + + integer iave,itot,immc,itrs,istn + data iave,itot,immc,itrs,istn/1,2,3,4,5/ + character*3 ctrs(ntr) + data ctrs/' ','TOT','MMC','TRS','STN'/ + + real zvQ(jjm,llm,ntr,nQ),zvQtmp(jjm,llm) + real zavQ(jjm,ntr,nQ),psiQ(jjm,llm+1,nQ) + real zmasse(jjm,llm),zamasse(jjm) + + real zv(jjm,llm),psi(jjm,llm+1) + + integer i,j,l,iQ + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + character*10 infile + + integer fileid + integer thoriid, zvertiid + save fileid + + integer ndex3d(jjm*llm) + +C Variables locales +C + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer ii,jj + integer zan, dayref +C + real rlong(jjm),rlatg(jjm) + integer :: jjb,jje,jjn,ijb,ije + type(Request) :: Req + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(1) :: ddid + INTEGER,DIMENSION(1) :: dsg + INTEGER,DIMENSION(1) :: dsl + INTEGER,DIMENSION(1) :: dpf + INTEGER,DIMENSION(1) :: dpl + INTEGER,DIMENSION(1) :: dhs + INTEGER,DIMENSION(1) :: dhe + + INTEGER :: bilan_dyn_domain_id + + +c===================================================================== +c Initialisation +c===================================================================== + ndex3d=0 + if (adjust) return + + time=time+dt_app + itau=itau+1 + + if (first) then + + + icum=0 +c initialisation des fichiers + first=.false. +c ncum est la frequence de stokage en pas de temps + ncum=dt_cum/dt_app + if (abs(ncum*dt_app-dt_cum).gt.1.e-5*dt_app) then + WRITE(lunout,*) + . 'Pb : le pas de cumule doit etre multiple du pas' + WRITE(lunout,*)'dt_app=',dt_app + WRITE(lunout,*)'dt_cum=',dt_cum + stop + endif + + if (i_sortie.eq.1) then + file='dynzon' + if (mpi_rank==0) then + call inigrads(ifile,1 + s ,0.,180./pi,0.,0.,jjm,rlatv,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dt_cum,file,'dyn_zon ') + endif + endif + + nom(itemp)='T' + nom(igeop)='gz' + nom(iecin)='K' + nom(iang)='ang' + nom(iu)='u' + nom(iovap)='ovap' + nom(iun)='un' + + unites(itemp)='K' + unites(igeop)='m2/s2' + unites(iecin)='m2/s2' + unites(iang)='ang' + unites(iu)='m/s' + unites(iovap)='kg/kg' + unites(iun)='un' + + +c Initialisation du fichier contenant les moyennes zonales. +c --------------------------------------------------------- + + infile='dynzon' + + zan = annee_ref + dayref = day_ref + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + rlong=0. + rlatg=rlatv*180./pi + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + IF (pole_sud) THEN + jjn=jj_nb-1 + jje=jj_end-1 + ENDIF + + ddid=(/ 2 /) + dsg=(/ jjm /) + dsl=(/ jjn /) + dpf=(/ jjb /) + dpl=(/ jje /) + dhs=(/ 0 /) + dhe=(/ 0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',bilan_dyn_domain_id) + + call histbeg(trim(infile), + . 1, rlong(jjb:jje), jjn, rlatg(jjb:jje), + . 1, 1, 1, jjn, + . tau0, zjulian, dt_cum, thoriid, fileid, + . bilan_dyn_domain_id) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'presnivs', 'Niveaux sigma','mb', + . llm, presnivs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder + do iQ=1,nQ + do itr=1,ntr + if(itr.eq.1) then + znom(itr,iQ)=nom(iQ) + znoml(itr,iQ)=nom(iQ) + zunites(itr,iQ)=unites(iQ) + else + znom(itr,iQ)=ctrs(itr)//'v'//nom(iQ) + znoml(itr,iQ)='transport : v * '//nom(iQ)//' '//ctrs(itr) + zunites(itr,iQ)='m/s * '//unites(iQ) + endif + enddo + enddo + +c Declarations des champs avec dimension verticale +c print*,'1HISTDEF' + do iQ=1,nQ + do itr=1,ntr + IF (prt_level > 5) + . WRITE(lunout,*)'var ',itr,iQ + . ,znom(itr,iQ),znoml(itr,iQ),zunites(itr,iQ) + call histdef(fileid,znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo +c Declarations pour les fonctions de courant +c print*,'2HISTDEF' + call histdef(fileid,'psi'//nom(iQ) + . ,'stream fn. '//znoml(itot,iQ), + . zunites(itot,iQ),1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + + +c Declarations pour les champs de transport d'air +c print*,'3HISTDEF' + call histdef(fileid, 'masse', 'masse', + . 'kg', 1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) + call histdef(fileid, 'v', 'v', + . 'm/s', 1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', dt_cum, dt_cum) +c Declarations pour les fonctions de courant +c print*,'4HISTDEF' + call histdef(fileid,'psi','stream fn. MMC ','mega t/s', + . 1,jjn,thoriid,llm,1,llm,zvertiid, + . 32,'ave(X)',dt_cum,dt_cum) + + +c Declaration des champs 1D de transport en latitude +c print*,'5HISTDEF' + do iQ=1,nQ + do itr=2,ntr + call histdef(fileid,'a'//znom(itr,iQ),znoml(itr,iQ), + . zunites(itr,iQ),1,jjn,thoriid,1,1,1,-99, + . 32,'ave(X)',dt_cum,dt_cum) + enddo + enddo + + +c print*,'8HISTDEF' + CALL histend(fileid) + + + endif + + +c===================================================================== +c Calcul des champs dynamiques +c ---------------------------- + + jjb=jj_begin + jje=jj_end + +c énergie cinétique + ucont(:,jjb:jje,:)=0 + + call Register_Hallo(ucov,ip1jmp1,llm,1,1,1,1,Req) + call Register_Hallo(vcov,ip1jm,llm,1,1,1,1,Req) + call SendRequest(Req) + call WaitRequest(Req) + + CALL covcont_p(llm,ucov,vcov,ucont,vcont) + CALL enercin_p(vcov,ucov,vcont,ucont,ecin) + +c moment cinétique + do l=1,llm + ang(:,jjb:jje,l)=ucov(:,jjb:jje,l)+constang(:,jjb:jje) + unat(:,jjb:jje,l)=ucont(:,jjb:jje,l)*cu(:,jjb:jje) + enddo + + Q(:,jjb:jje,:,itemp)=teta(:,jjb:jje,:)*pk(:,jjb:jje,:)/cpp + Q(:,jjb:jje,:,igeop)=phi(:,jjb:jje,:) + Q(:,jjb:jje,:,iecin)=ecin(:,jjb:jje,:) + Q(:,jjb:jje,:,iang)=ang(:,jjb:jje,:) + Q(:,jjb:jje,:,iu)=unat(:,jjb:jje,:) + Q(:,jjb:jje,:,iovap)=trac(:,jjb:jje,:,1) + Q(:,jjb:jje,:,iun)=1. + + +c===================================================================== +c Cumul +c===================================================================== +c + if(icum.EQ.0) then + jjb=jj_begin + jje=jj_end + + ps_cum(:,jjb:jje)=0. + masse_cum(:,jjb:jje,:)=0. + flux_u_cum(:,jjb:jje,:)=0. + Q_cum(:,jjb:jje,:,:)=0. + flux_uQ_cum(:,jjb:jje,:,:)=0. + flux_v_cum(:,jjb:jje,:)=0. + if (pole_sud) jje=jj_end-1 + flux_v_cum(:,jjb:jje,:)=0. + flux_vQ_cum(:,jjb:jje,:,:)=0. + endif + + IF (prt_level > 5) + . WRITE(lunout,*)'dans bilan_dyn ',icum,'->',icum+1 + icum=icum+1 + +c accumulation des flux de masse horizontaux + jjb=jj_begin + jje=jj_end + + ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)+ps(:,jjb:jje) + masse_cum(:,jjb:jje,:)=masse_cum(:,jjb:jje,:)+masse(:,jjb:jje,:) + flux_u_cum(:,jjb:jje,:)=flux_u_cum(:,jjb:jje,:) + . +flux_u(:,jjb:jje,:) + if (pole_sud) jje=jj_end-1 + flux_v_cum(:,jjb:jje,:)=flux_v_cum(:,jjb:jje,:) + . +flux_v(:,jjb:jje,:) + + jjb=jj_begin + jje=jj_end + + do iQ=1,nQ + Q_cum(:,jjb:jje,:,iQ)=Q_cum(:,jjb:jje,:,iQ) + . +Q(:,jjb:jje,:,iQ)*masse(:,jjb:jje,:) + enddo + +c===================================================================== +c FLUX ET TENDANCES +c===================================================================== + +c Flux longitudinal +c ----------------- + do iQ=1,nQ + do l=1,llm + do j=jjb,jje + do i=1,iim + flux_uQ_cum(i,j,l,iQ)=flux_uQ_cum(i,j,l,iQ) + s +flux_u(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i+1,j,l,iQ)) + enddo + flux_uQ_cum(iip1,j,l,iQ)=flux_uQ_cum(1,j,l,iQ) + enddo + enddo + enddo + +c flux méridien +c ------------- + do iQ=1,nQ + call Register_Hallo(Q(1,1,1,iQ),ip1jmp1,llm,0,1,1,0,Req) + enddo + call SendRequest(Req) + call WaitRequest(Req) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do iQ=1,nQ + do l=1,llm + do j=jjb,jje + do i=1,iip1 + flux_vQ_cum(i,j,l,iQ)=flux_vQ_cum(i,j,l,iQ) + s +flux_v(i,j,l)*0.5*(Q(i,j,l,iQ)+Q(i,j+1,l,iQ)) + enddo + enddo + enddo + enddo + + +c tendances +c --------- + +c convergence horizontale + call Register_Hallo(flux_uQ_cum,ip1jmp1,llm,2,2,2,2,Req) + call Register_Hallo(flux_vQ_cum,ip1jm,llm,2,2,2,2,Req) + call SendRequest(Req) + call WaitRequest(Req) + + call convflu_p(flux_uQ_cum,flux_vQ_cum,llm*nQ,dQ) + +c calcul de la vitesse verticale + call Register_Hallo(flux_u_cum,ip1jmp1,llm,2,2,2,2,Req) + call Register_Hallo(flux_v_cum,ip1jm,llm,2,2,2,2,Req) + call SendRequest(Req) + call WaitRequest(Req) + + call convmas_p(flux_u_cum,flux_v_cum,convm) + CALL vitvert_p(convm,w) + + jjb=jj_begin + jje=jj_end + + do iQ=1,nQ + do l=1,llm-1 + do j=jjb,jje + do i=1,iip1 + ww=-0.5*w(i,j,l+1)*(Q(i,j,l,iQ)+Q(i,j,l+1,iQ)) + dQ(i,j,l ,iQ)=dQ(i,j,l ,iQ)-ww + dQ(i,j,l+1,iQ)=dQ(i,j,l+1,iQ)+ww + enddo + enddo + enddo + enddo + IF (prt_level > 5) + . WRITE(lunout,*)'Apres les calculs fait a chaque pas' +c===================================================================== +c PAS DE TEMPS D'ECRITURE +c===================================================================== + if (icum.eq.ncum) then +c===================================================================== + + IF (prt_level > 5) + . WRITE(lunout,*)'Pas d ecriture' + +c Normalisation + do iQ=1,nQ + Q_cum(:,jjb:jje,:,iQ)=Q_cum(:,jjb:jje,:,iQ) + . /masse_cum(:,jjb:jje,:) + enddo + zz=1./REAL(ncum) + + jjb=jj_begin + jje=jj_end + + ps_cum(:,jjb:jje)=ps_cum(:,jjb:jje)*zz + masse_cum(:,jjb:jje,:)=masse_cum(:,jjb:jje,:)*zz + flux_u_cum(:,jjb:jje,:)=flux_u_cum(:,jjb:jje,:)*zz + flux_uQ_cum(:,jjb:jje,:,:)=flux_uQ_cum(:,jjb:jje,:,:)*zz + dQ(:,jjb:jje,:,:)=dQ(:,jjb:jje,:,:)*zz + + IF (pole_sud) jje=jj_end-1 + flux_v_cum(:,jjb:jje,:)=flux_v_cum(:,jjb:jje,:)*zz + flux_vQ_cum(:,jjb:jje,:,:)=flux_vQ_cum(:,jjb:jje,:,:)*zz + + jjb=jj_begin + jje=jj_end + + +c A retravailler eventuellement +c division de dQ par la masse pour revenir aux bonnes grandeurs + do iQ=1,nQ + dQ(:,jjb:jje,:,iQ)=dQ(:,jjb:jje,:,iQ)/masse_cum(:,jjb:jje,:) + enddo + +c===================================================================== +c Transport méridien +c===================================================================== + +c cumul zonal des masses des mailles +c ---------------------------------- + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + zv(jjb:jje,:)=0. + zmasse(jjb:jje,:)=0. + + call Register_Hallo(masse_cum,ip1jmp1,llm,1,1,1,1,Req) + do iQ=1,nQ + call Register_Hallo(Q_cum(1,1,1,iQ),ip1jmp1,llm,0,1,1,0,Req) + enddo + + call SendRequest(Req) + call WaitRequest(Req) + + call massbar_p(masse_cum,massebx,masseby) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do l=1,llm + do j=jjb,jje + do i=1,iim + zmasse(j,l)=zmasse(j,l)+masseby(i,j,l) + zv(j,l)=zv(j,l)+flux_v_cum(i,j,l) + enddo + zfactv(j,l)=cv(1,j)/zmasse(j,l) + enddo + enddo + +c print*,'3OK' +c -------------------------------------------------------------- +c calcul de la moyenne zonale du transport : +c ------------------------------------------ +c +c -- +c TOT : la circulation totale [ vq ] +c +c - - +c MMC : mean meridional circulation [ v ] [ q ] +c +c ---- -- - - +c TRS : transitoires [ v'q'] = [ vq ] - [ v q ] +c +c - * - * - - - - +c STT : stationaires [ v q ] = [ v q ] - [ v ] [ q ] +c +c - - +c on utilise aussi l'intermediaire TMP : [ v q ] +c +c la variable zfactv transforme un transport meridien cumule +c en kg/s * unte-du-champ-transporte en m/s * unite-du-champ-transporte +c +c -------------------------------------------------------------- + + +c ---------------------------------------- +c Transport dans le plan latitude-altitude +c ---------------------------------------- + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + zvQ=0. + psiQ=0. + do iQ=1,nQ + zvQtmp=0. + do l=1,llm + do j=jjb,jje +c print*,'j,l,iQ=',j,l,iQ +c Calcul des moyennes zonales du transort total et de zvQtmp + do i=1,iim + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ) + s +flux_vQ_cum(i,j,l,iQ) + zqy= 0.5*(Q_cum(i,j,l,iQ)*masse_cum(i,j,l)+ + s Q_cum(i,j+1,l,iQ)*masse_cum(i,j+1,l)) + zvQtmp(j,l)=zvQtmp(j,l)+flux_v_cum(i,j,l)*zqy + s /(0.5*(masse_cum(i,j,l)+masse_cum(i,j+1,l))) + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)+zqy + enddo +c print*,'aOK' +c Decomposition + zvQ(j,l,iave,iQ)=zvQ(j,l,iave,iQ)/zmasse(j,l) + zvQ(j,l,itot,iQ)=zvQ(j,l,itot,iQ)*zfactv(j,l) + zvQtmp(j,l)=zvQtmp(j,l)*zfactv(j,l) + zvQ(j,l,immc,iQ)=zv(j,l)*zvQ(j,l,iave,iQ)*zfactv(j,l) + zvQ(j,l,itrs,iQ)=zvQ(j,l,itot,iQ)-zvQtmp(j,l) + zvQ(j,l,istn,iQ)=zvQtmp(j,l)-zvQ(j,l,immc,iQ) + enddo + enddo +c fonction de courant meridienne pour la quantite Q + do l=llm,1,-1 + do j=jjb,jje + psiQ(j,l,iQ)=psiQ(j,l+1,iQ)+zvQ(j,l,itot,iQ) + enddo + enddo + enddo + +c fonction de courant pour la circulation meridienne moyenne + psi(jjb:jje,:)=0. + do l=llm,1,-1 + do j=jjb,jje + psi(j,l)=psi(j,l+1)+zv(j,l) + zv(j,l)=zv(j,l)*zfactv(j,l) + enddo + enddo + +c print*,'4OK' +c sorties proprement dites + if (i_sortie.eq.1) then + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) jje=jj_end-1 + if (pole_sud) jjn=jj_nb-1 + + do iQ=1,nQ + do itr=1,ntr + call histwrite(fileid,znom(itr,iQ),itau, + s zvQ(jjb:jje,:,itr,iQ) + s ,jjn*llm,ndex3d) + enddo + call histwrite(fileid,'psi'//nom(iQ), + s itau,psiQ(jjb:jje,1:llm,iQ) + s ,jjn*llm,ndex3d) + enddo + + call histwrite(fileid,'masse',itau,zmasse(jjb:jje,1:llm) + s ,jjn*llm,ndex3d) + call histwrite(fileid,'v',itau,zv(jjb:jje,1:llm) + s ,jjn*llm,ndex3d) + psi(jjb:jje,:)=psi(jjb:jje,:)*1.e-9 + call histwrite(fileid,'psi',itau,psi(jjb:jje,1:llm), + s jjn*llm,ndex3d) + + endif + + +c ----------------- +c Moyenne verticale +c ----------------- + + zamasse(jjb:jje)=0. + do l=1,llm + zamasse(jjb:jje)=zamasse(jjb:jje)+zmasse(jjb:jje,l) + enddo + + zavQ(jjb:jje,:,:)=0. + do iQ=1,nQ + do itr=2,ntr + do l=1,llm + zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ) + s +zvQ(jjb:jje,l,itr,iQ) + s *zmasse(jjb:jje,l) + enddo + zavQ(jjb:jje,itr,iQ)=zavQ(jjb:jje,itr,iQ)/zamasse(jjb:jje) + call histwrite(fileid,'a'//znom(itr,iQ),itau, + s zavQ(jjb:jje,itr,iQ),jjn*llm,ndex3d) + enddo + enddo + +c on doit pouvoir tracer systematiquement la fonction de courant. + +c===================================================================== +c///////////////////////////////////////////////////////////////////// + icum=0 !/////////////////////////////////////// + endif ! icum.eq.ncum !/////////////////////////////////////// +c///////////////////////////////////////////////////////////////////// +c===================================================================== + + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/caladvtrac_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/caladvtrac_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/caladvtrac_loc.F (revision 1632) @@ -0,0 +1,211 @@ +! +! $Id: caladvtrac_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c +c + SUBROUTINE caladvtrac_loc(q,pbaru,pbarv , + * p ,masse, dq , teta, + * flxw, pk, iapptrac) + USE parallel + USE infotrac + USE control_mod + USE caladvtrac_mod + USE mod_hallo + USE bands + USE times + USE Vampir + USE write_field_loc +c + IMPLICIT NONE +c +c Auteurs: F.Hourdin , P.Le Van, F.Forget, F.Codron +c +c F.Codron (10/99) : ajout humidite specifique pour eau vapeur +c======================================================================= +c +c Shema de Van Leer +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" + +c Arguments: +c ---------- + REAL :: pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm) + REAL :: masse(ijb_u:ije_u,llm) + REAL :: p( ijb_u:ije_u,llmp1) + REAL :: q( ijb_u:ije_u,llm,nqtot),dq( ijb_u:ije_u,llm,2 ) + REAL :: teta( ijb_u:ije_u,llm),pk( ijb_u:ije_u,llm) + REAL :: flxw(ijb_u:ije_u,llm) + INTEGER :: iapptrac +c Local: +c ------ +! REAL :: pbarug(ijb_u:ije_u,llm) +! REAL :: pbarvg(ijb_v:ije_v,llm) +! REAL :: wg(ijb_u:ije_u,llm) + + REAL :: flxw_adv(distrib_vanleer%ijb_u:distrib_vanleer%ije_u,llm) + INTEGER,SAVE :: iadvtr=0 +!$OMP THREADPRIVATE(iadvtr) + INTEGER :: ijb,ije,ijbu,ijbv,ijeu,ijev,j + INTEGER :: ij,l + TYPE(Request) :: Request_vanleer + + + + ijbu=ij_begin + ijeu=ij_end + + ijbv=ij_begin-iip1 + ijev=ij_end + if (pole_nord) ijbv=ij_begin + if (pole_sud) ijev=ij_end-iip1 + + IF(iadvtr.EQ.0) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + pbaruc(ijbu:ijeu,l)=0. + pbarvc(ijbv:ijev,l)=0. + ENDDO +c$OMP END DO NOWAIT + ENDIF + +c accumulation des flux de masse horizontaux +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij = ijbu,ijeu + pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l) + ENDDO + DO ij = ijbv,ijev + pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c selection de la masse instantannee des mailles avant le transport. + IF(iadvtr.EQ.0) THEN + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + massem(ijb:ije,l)=masse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + ENDIF + + iadvtr = iadvtr+1 + +c$OMP MASTER + iapptrac = iadvtr +c$OMP END MASTER + +c Test pour savoir si on advecte a ce pas de temps + + IF ( iadvtr.EQ.iapp_tracvl ) THEN +c$OMP MASTER + call suspend_timer(timer_caldyn) +c$OMP END MASTER + + ijb=ij_begin + ije=ij_end + +cc .. Modif P.Le Van ( 20/12/97 ) .... +cc + +c traitement des flux de masse avant advection. +c 1. calcul de w +c 2. groupement des mailles pres du pole. + pbarvg(:,:)=-1 + pbarvg_adv(:,:)=-2 + CALL groupe_loc( massem, pbaruc,pbarvc, pbarug,pbarvg,wg ) + flxw(ijb:ije,1:llm)=wg(ijb:ije,1:llm)/REAL(iapp_tracvl) + +#ifdef DEBUG_IO + CALL WriteField_u('pbarug1',pbarug) + CALL WriteField_v('pbarvg1',pbarvg) + CALL WriteField_u('wg1',wg) +#endif + +c$OMP BARRIER + + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call Register_SwapField_u(pbarug,pbarug_adv, distrib_vanleer, + & Request_vanleer) + call Register_SwapField_v(pbarvg,pbarvg_adv, distrib_vanleer, + & Request_vanleer,up=1) + call Register_SwapField_u(massem,massem_adv, distrib_vanleer, + & Request_vanleer) + call Register_SwapField_u(wg,wg_adv,distrib_vanleer, + & Request_vanleer) + call Register_SwapField_u(teta,teta_adv, distrib_vanleer, + & Request_vanleer,up=1,down=1) + call Register_SwapField_u(p,p_adv, distrib_vanleer, + & Request_vanleer,up=1,down=1) + call Register_SwapField_u(pk,pk_adv, distrib_vanleer, + & Request_vanleer,up=1,down=1) + call Register_SwapField_u(q,q_adv, distrib_vanleer, + & Request_vanleer) + + call SendRequest(Request_vanleer) +c$OMP BARRIER + call WaitRequest(Request_vanleer) + + +c$OMP BARRIER +c$OMP MASTER + call Set_Distrib(distrib_vanleer) + call VTe(VTHallo) + call VTb(VTadvection) + call start_timer(timer_vanleer) +c$OMP END MASTER +c$OMP BARRIER +! CALL WriteField_u('pbarug_adv',pbarug_adv) +! CALL WriteField_u('',) + + +#ifdef DEBUG_IO + CALL WriteField_u('pbarug1',pbarug_adv) + CALL WriteField_v('pbarvg1',pbarvg_adv) + CALL WriteField_u('wg1',wg_adv) +#endif + CALL advtrac_loc( pbarug_adv,pbarvg_adv,wg_adv, + * p_adv, massem_adv,q_adv, teta_adv, + . pk_adv) + + +c$OMP MASTER + call VTe(VTadvection) + call stop_timer(timer_vanleer) + call VTb(VThallo) +c$OMP END MASTER + + call Register_SwapField_u(q_adv,q,distrib_caldyn, + * Request_vanleer) + + call SendRequest(Request_vanleer) +c$OMP BARRIER + call WaitRequest(Request_vanleer) + +c$OMP BARRIER +c$OMP MASTER + call Set_Distrib(distrib_caldyn) + call VTe(VThallo) + call resume_timer(timer_caldyn) +c$OMP END MASTER +c$OMP BARRIER + iadvtr=0 + ENDIF ! if iadvtr.EQ.iapp_tracvl + + END + + Index: /LMDZ5/trunk/libf/dyn3dmem/caladvtrac_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/caladvtrac_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/caladvtrac_mod.F90 (revision 1632) @@ -0,0 +1,96 @@ +MODULE caladvtrac_mod + + REAL,POINTER,SAVE :: q_adv(:,:,:) + REAL,POINTER,SAVE :: massem_adv(:,:) + REAL,POINTER,SAVE :: wg_adv(:,:) + REAL,POINTER,SAVE :: teta_adv(:,:) + REAL,POINTER,SAVE :: p_adv(:,:) + REAL,POINTER,SAVE :: pk_adv(:,:) + REAL,POINTER,SAVE :: pbarug_adv(:,:) + REAL,POINTER,SAVE :: pbarvg_adv(:,:) + REAL,POINTER,SAVE :: pbaruc(:,:) + REAL,POINTER,SAVE :: pbarvc(:,:) + REAL,POINTER,SAVE :: pbarug(:,:) + REAL,POINTER,SAVE :: pbarvg(:,:) + REAL,POINTER,SAVE :: wg(:,:) + + REAL,POINTER,SAVE :: massem(:,:) + +CONTAINS + + SUBROUTINE caladvtrac_allocate + USE bands + USE allocate_field + USE parallel + USE infotrac + USE advtrac_mod, ONLY : advtrac_allocate + USE groupe_mod + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + TYPE(distrib),POINTER :: d + + d=>distrib_vanleer + CALL allocate_u(q_adv,llm,nqtot,d) + CALL allocate_u(massem_adv,llm,d) + CALL allocate_u(wg_adv,llm,d) + CALL allocate_u(teta_adv,llm,d) + CALL allocate_u(p_adv,llmp1,d) + CALL allocate_u(pk_adv,llm,d) + CALL allocate_u(pbarug_adv,llm,d) + CALL allocate_v(pbarvg_adv,llm,d) + + d=>distrib_caldyn + CALL allocate_u(massem,llm,d) + CALL allocate_u(pbaruc,llm,d) + CALL allocate_v(pbarvc,llm,d) + CALL allocate_u(pbarug,llm,d) + CALL allocate_v(pbarvg,llm,d) + CALL allocate_u(wg,llm,d) + + CALL groupe_allocate + CALL advtrac_allocate + + END SUBROUTINE caladvtrac_allocate + + SUBROUTINE caladvtrac_switch_caldyn(dist) + USE allocate_field + USE bands + USE parallel + USE groupe_mod + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(massem,distrib_caldyn,dist) + CALL switch_u(pbaruc,distrib_caldyn,dist) + CALL switch_v(pbarvc,distrib_caldyn,dist,up=1) + CALL switch_u(pbarug,distrib_caldyn,dist) + CALL switch_v(pbarvg,distrib_caldyn,dist) + CALL switch_u(wg,distrib_caldyn,dist) + + CALL groupe_switch_caldyn(dist) + + END SUBROUTINE caladvtrac_switch_caldyn + + SUBROUTINE caladvtrac_switch_vanleer(dist) + USE allocate_field + USE bands + USE parallel + USE advtrac_mod, ONLY : advtrac_switch_vanleer + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(q_adv,distrib_vanleer,dist) + CALL switch_u(massem_adv,distrib_vanleer,dist) + CALL switch_u(wg_adv,distrib_vanleer,dist) + CALL switch_u(teta_adv,distrib_vanleer,dist) + CALL switch_u(p_adv,distrib_vanleer,dist) + CALL switch_u(pk_adv,distrib_vanleer,dist) + CALL switch_u(pbarug_adv,distrib_vanleer,dist) + CALL switch_v(pbarvg_adv,distrib_vanleer,dist) + + CALL advtrac_switch_vanleer(dist) + + END SUBROUTINE caladvtrac_switch_vanleer + +END MODULE caladvtrac_mod Index: /LMDZ5/trunk/libf/dyn3dmem/caldyn0.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/caldyn0.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/caldyn0.F (revision 1632) @@ -0,0 +1,89 @@ +! +! $Header$ +! + SUBROUTINE caldyn0 + $ (itau,ucov,vcov,teta,ps,masse,pk,phis , + $ phi,w,pbaru,pbarv,time ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteur : P. Le Van +c +c Objet: +c ------ +c +c Calcul des tendances dynamiques. +c +c Modif 04/93 F.Forget +c======================================================================= + +c----------------------------------------------------------------------- +c 0. Declarations: +c ---------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER itau + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + REAL pk(iip1,jjp1,llm) + REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL phi(ip1jmp1,llm),masse(ip1jmp1,llm) + REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL time + +c Local: +c ------ + + REAL ang(ip1jmp1,llm),p(ip1jmp1,llmp1) + REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm),psexbarxy(ip1jm) + REAL vorpot(ip1jm,llm) + REAL w(ip1jmp1,llm),ecin(ip1jmp1,llm),convm(ip1jmp1,llm) + REAL bern(ip1jmp1,llm) + REAL massebxy(ip1jm,llm), dp(ip1jmp1) + + + INTEGER ij,l + +c----------------------------------------------------------------------- +c Calcul des tendances dynamiques: +c -------------------------------- + + CALL covcont ( llm , ucov , vcov , ucont, vcont ) + CALL pression ( ip1jmp1, ap , bp , ps , p ) + CALL psextbar ( ps , psexbarxy ) + CALL massdair ( p , masse ) + CALL massbar ( masse, massebx , masseby ) + CALL massbarxy( masse, massebxy ) + CALL flumass ( massebx, masseby , vcont, ucont ,pbaru, pbarv ) + CALL convmas ( pbaru, pbarv , convm ) + + DO ij =1, ip1jmp1 + dp( ij ) = convm( ij,1 ) / airesurg( ij ) + ENDDO + + CALL vitvert ( convm , w ) + CALL tourpot ( vcov , ucov , massebxy , vorpot ) + CALL enercin ( vcov , ucov , vcont , ucont , ecin ) + CALL bernoui ( ip1jmp1, llm , phi , ecin , bern ) + + DO l=1,llm + DO ij=1,ip1jmp1 + ang(ij,l) = ucov(ij,l) + constang(ij) + ENDDO + ENDDO + + CALL sortvarc0 + $ ( itau,ucov,teta,ps,masse,pk,phis,vorpot,phi,bern,dp,time,vcov ) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/caldyn_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/caldyn_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/caldyn_loc.F (revision 1632) @@ -0,0 +1,162 @@ +! +! $Header$ +! +c +c +#undef DEBUG_IO +!#define DEBUG_IO + + SUBROUTINE caldyn_loc + $ (itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , + $ phi,conser,du,dv,dteta,dp,w,pbaru,pbarv,time ) + USE parallel + USE Write_Field_loc + USE caldyn_mod + + IMPLICIT NONE + +c======================================================================= +c +c Auteur : P. Le Van +c +c Objet: +c ------ +c +c Calcul des tendances dynamiques. +c +c Modif 04/93 F.Forget +c======================================================================= + +c----------------------------------------------------------------------- +c 0. Declarations: +c ---------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + LOGICAL conser + + INTEGER itau + REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) + REAL teta(ijb_u:ije_u,llm) + REAL ps(ijb_u:ije_u),phis(ijb_u:ije_u) + REAL pk(iip1,jjb_u:jje_u,llm),pkf(ijb_u:ije_u,llm) + REAL phi(ijb_u:ije_u,llm),masse(ijb_u:ije_u,llm) + REAL dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm) + REAL dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u) + REAL w(ijb_u:ije_u,llm) + REAL pbaru(ijb_u:ije_u,llm),pbarv(ijb_v:ije_v,llm) + REAL time + +c Local: +c ------ + + INTEGER ij,l,ijb,ije,ierr + + +c----------------------------------------------------------------------- +c Calcul des tendances dynamiques: +c -------------------------------- + CALL covcont_loc ( llm , ucov , vcov , ucont, vcont ) + CALL pression_loc ( ip1jmp1, ap , bp , ps , p ) +cym CALL psextbar ( ps , psexbarxy ) +c$OMP BARRIER + CALL massdair_loc ( p , masse ) + CALL massbar_loc ( masse, massebx , masseby ) + call massbarxy_loc( masse, massebxy ) + CALL flumass_loc ( massebx, masseby,vcont,ucont,pbaru,pbarv ) + CALL dteta1_loc ( teta , pbaru , pbarv, dteta ) + CALL convmas1_loc ( pbaru, pbarv , convm ) +c$OMP BARRIER + CALL convmas2_loc ( convm ) +c$OMP BARRIER +#ifdef DEBUG_IO + call WriteField_u('ucont',ucont) + call WriteField_v('vcont',vcont) + call WriteField_u('p',p) + call WriteField_u('masse',masse) + call WriteField_u('massebx',massebx) + call WriteField_v('masseby',masseby) + call WriteField_v('massebxy',massebxy) + call WriteField_u('pbaru',pbaru) + call WriteField_v('pbarv',pbarv) + call WriteField_u('dteta',dteta) + call WriteField_u('convm',convm) +#endif + +c$OMP BARRIER +c$OMP MASTER + ijb=ij_begin + ije=ij_end + + DO ij =ijb, ije + dp( ij ) = convm( ij,1 ) / airesurg( ij ) + ENDDO +c$OMP END MASTER +c$OMP BARRIER + CALL vitvert_loc ( convm , w ) + CALL tourpot_loc ( vcov , ucov , massebxy , vorpot ) + CALL dudv1_loc ( vorpot , pbaru , pbarv , du , dv ) + +#ifdef DEBUG_IO + call WriteField_u('w',w) + call WriteField_v('vorpot',vorpot) + call WriteField_u('du',du) + call WriteField_v('dv',dv) +#endif + CALL enercin_loc ( vcov , ucov , vcont , ucont , ecin ) + CALL bernoui_loc ( ip1jmp1, llm , phi , ecin , bern) + CALL dudv2_loc ( teta , pkf , bern , du , dv ) + +#ifdef DEBUG_IO + call WriteField_u('ecin',ecin) + call WriteField_u('bern',bern) + call WriteField_u('du',du) + call WriteField_v('dv',dv) + call WriteField_u('pkf',pkf) +#endif + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + ang(ij,l) = ucov(ij,l) + constang(ij) + ENDDO + ENDDO +c$OMP END DO + + CALL advect_new_loc(ang,vcov,teta,w,massebx,masseby,du,dv,dteta) + +C WARNING probleme de peridocite de dv sur les PC/linux. Pb d'arrondi +C probablement. Observe sur le code compile avec pgf90 3.0-1 + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije, iip1 + IF( dv(ij,l).NE.dv(ij+iim,l) ) THEN +c PRINT *,'!!!ATTENTION!!! probleme de periodicite sur vcov', +c , ' dans caldyn' +c PRINT *,' l, ij = ', l, ij, ij+iim,dv(ij+iim,l),dv(ij,l) + dv(ij+iim,l) = dv(ij,l) + endif + enddo + enddo +c$OMP END DO NOWAIT + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/caldyn_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/caldyn_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/caldyn_mod.F90 (revision 1632) @@ -0,0 +1,75 @@ +MODULE caldyn_mod + + REAL,POINTER,SAVE :: vcont(:,:) + REAL,POINTER,SAVE :: ucont(:,:) + REAL,POINTER,SAVE :: ang(:,:) + REAL,POINTER,SAVE :: p(:,:) + REAL,POINTER,SAVE :: massebx(:,:) + REAL,POINTER,SAVE :: masseby(:,:) + REAL,POINTER,SAVE :: psexbarxy(:,:) + REAL,POINTER,SAVE :: vorpot(:,:) + REAL,POINTER,SAVE :: ecin(:,:) + REAL,POINTER,SAVE :: bern(:,:) + REAL,POINTER,SAVE :: massebxy(:,:) + REAL,POINTER,SAVE :: convm(:,:) + + + +CONTAINS + + SUBROUTINE caldyn_allocate + USE bands + USE allocate_field + USE parallel + USE dimensions + USE advect_new_mod,ONLY : advect_new_allocate + IMPLICIT NONE + TYPE(distrib),POINTER :: d + + + d=>distrib_caldyn + CALL allocate_v(vcont,llm,d) + CALL allocate_u(ucont,llm,d) + CALL allocate_u(ang,llm,d) + CALL allocate_u(p,llmp1,d) + CALL allocate_u(massebx,llm,d) + CALL allocate_v(masseby,llm,d) + CALL allocate_v(psexbarxy,llm,d) + CALL allocate_v(vorpot,llm,d) + CALL allocate_u(ecin,llm,d) + CALL allocate_u(bern,llm,d) + CALL allocate_v(massebxy,llm,d) + CALL allocate_u(convm,llm,d) + + CALL advect_new_allocate + + END SUBROUTINE caldyn_allocate + + SUBROUTINE caldyn_switch_caldyn(dist) + USE allocate_field + USE bands + USE parallel + USE advect_new_mod,ONLY : advect_new_switch_caldyn + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_v(vcont,distrib_caldyn,dist) + CALL switch_u(ucont,distrib_caldyn,dist) + CALL switch_u(ang,distrib_caldyn,dist) + CALL switch_u(p,distrib_caldyn,dist) + CALL switch_u(massebx,distrib_caldyn,dist) + CALL switch_v(masseby,distrib_caldyn,dist) + CALL switch_v(psexbarxy,distrib_caldyn,dist) + CALL switch_v(vorpot,distrib_caldyn,dist) + CALL switch_u(ecin,distrib_caldyn,dist) + CALL switch_u(bern,distrib_caldyn,dist) + CALL switch_v(massebxy,distrib_caldyn,dist) + CALL switch_u(convm,distrib_caldyn,dist) + + CALL advect_new_switch_caldyn(dist) + + END SUBROUTINE caldyn_switch_caldyn + + + +END MODULE caldyn_mod Index: /LMDZ5/trunk/libf/dyn3dmem/calfis_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/calfis_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/calfis_loc.F (revision 1632) @@ -0,0 +1,1122 @@ +! +! $Id: calfis_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! +C +C + SUBROUTINE calfis_loc(lafin, + $ jD_cur, jH_cur, + $ pucov, + $ pvcov, + $ pteta, + $ pq, + $ pmasse, + $ pps, + $ pp, + $ ppk, + $ pphis, + $ pphi, + $ pducov, + $ pdvcov, + $ pdteta, + $ pdq, + $ flxw, + $ clesphy0, + $ pdufi, + $ pdvfi, + $ pdhfi, + $ pdqfi, + $ pdpsfi) +#ifdef CPP_EARTH +! Ehouarn: For now, calfis_p needs Earth physics +c +c Auteur : P. Le Van, F. Hourdin +c ......... + USE dimphy + USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root + USE parallel, ONLY : omp_chunk, using_mpi,jjb_u,jje_u,jjb_v,jje_v + USE mod_interface_dyn_phys + USE Write_Field + Use Write_field_p + USE Times + USE IOPHY + USE infotrac + USE control_mod + + IMPLICIT NONE +c======================================================================= +c +c 1. rearrangement des tableaux et transformation +c variables dynamiques > variables physiques +c 2. calcul des termes physiques +c 3. retransformation des tendances physiques en tendances dynamiques +c +c remarques: +c ---------- +c +c - les vents sont donnes dans la physique par leurs composantes +c naturelles. +c - la variable thermodynamique de la physique est une variable +c intensive : T +c pour la dynamique on prend T * ( preff / p(l) ) **kappa +c - les deux seules variables dependant de la geometrie necessaires +c pour la physique sont la latitude pour le rayonnement et +c l'aire de la maille quand on veut integrer une grandeur +c horizontalement. +c - les points de la physique sont les points scalaires de la +c la dynamique; numerotation: +c 1 pour le pole nord +c (jjm-1)*iim pour l'interieur du domaine +c ngridmx pour le pole sud +c ---> ngridmx=2+(jjm-1)*iim +c +c Input : +c ------- +c ecritphy frequence d'ecriture (en jours)de histphy +c pucov covariant zonal velocity +c pvcov covariant meridional velocity +c pteta potential temperature +c pps surface pressure +c pmasse masse d'air dans chaque maille +c pts surface temperature (K) +c callrad clef d'appel au rayonnement +c +c Output : +c -------- +c pdufi tendency for the natural zonal velocity (ms-1) +c pdvfi tendency for the natural meridional velocity +c pdhfi tendency for the potential temperature +c pdtsfi tendency for the surface temperature +c +c pdtrad radiative tendencies \ both input +c pfluxrad radiative fluxes / and output +c +c======================================================================= +c +c----------------------------------------------------------------------- +c +c 0. Declarations : +c ------------------ + +#include "dimensions.h" +#include "paramet.h" +#include "temps.h" + + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif +c Arguments : +c ----------- + LOGICAL lafin + REAL heure + + REAL pvcov(iip1,jjb_v:jje_v,llm) + REAL pucov(iip1,jjb_u:jje_u,llm) + REAL pteta(iip1,jjb_u:jje_u,llm) + REAL pmasse(iip1,jjb_u:jje_u,llm) + REAL pq(iip1,jjb_u:jje_u,llm,nqtot) + REAL pphis(iip1,jjb_u:jje_u) + REAL pphi(iip1,jjb_u:jje_u,llm) +c + REAL pdvcov(iip1,jjb_v:jje_v,llm) + REAL pducov(iip1,jjb_u:jje_u,llm) + REAL pdteta(iip1,jjb_u:jje_u,llm) + REAL pdq(iip1,jjb_u:jje_u,llm,nqtot) +c + REAL pps(iip1,jjb_u:jje_u) + REAL pp(iip1,jjb_u:jje_u,llmp1) + REAL ppk(iip1,jjb_u:jje_u,llm) +c + REAL pdvfi(iip1,jjb_v:jje_v,llm) + REAL pdufi(iip1,jjb_u:jje_u,llm) + REAL pdhfi(iip1,jjb_u:jje_u,llm) + REAL pdqfi(iip1,jjb_u:jje_u,llm,nqtot) + REAL pdpsfi(iip1,jjb_u:jje_u) + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + +c Local variables : +c ----------------- + + INTEGER i,j,l,ig0,ig,iq,iiq + REAL,ALLOCATABLE,SAVE :: zpsrf(:) + REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:) + REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:) +c + REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:) + REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:) +c + REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:) + REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:) +c + REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:) + REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdpsrf(:) + REAL,SAVE,ALLOCATABLE :: flxwfi(:,:) ! Flux de masse verticale sur la grille physiq + +c + REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zphis_omp(:) + REAL,ALLOCATABLE,SAVE :: presnivs_omp(:) + REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:) + REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:) + REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:) + REAL,SAVE,ALLOCATABLE :: flxwfi_omp(:,:) ! Flux de masse verticale sur la grille physiq + +c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp, +c$OMP+ presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp, +c$OMP+ zqfi_omp,zdufi_omp,zdvfi_omp, +c$OMP+ zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp) + + LOGICAL,SAVE :: first_omp=.true. +c$OMP THREADPRIVATE(first_omp) + + REAL zsin(iim),zcos(iim),z1(iim) + REAL zsinbis(iim),zcosbis(iim),z1bis(iim) + REAL unskap, pksurcp +c +cIM diagnostique PVteta, Amip2 + INTEGER ntetaSTD + PARAMETER(ntetaSTD=3) + REAL rtetaSTD(ntetaSTD) + DATA rtetaSTD/350., 380., 405./ + REAL PVteta(klon,ntetaSTD) + + REAL flxw(iip1,jjb_u:jje_u,llm) ! Flux de masse verticale sur la grille dynamique + + REAL SSUM + + LOGICAL firstcal, debut + DATA firstcal/.true./ + SAVE firstcal,debut +c$OMP THREADPRIVATE(firstcal,debut) + REAL, intent(in):: jD_cur, jH_cur + + REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv + INTEGER :: ierr +#ifdef CPP_MPI + INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status +#else + INTEGER,dimension(1,4) :: Status +#endif + INTEGER, dimension(4) :: Req + REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:) + integer :: k,kstart,kend + INTEGER :: offset +c +c----------------------------------------------------------------------- +c +c 1. Initialisations : +c -------------------- +c + + klon=klon_mpi + + PVteta(:,:)=0. + +c + IF ( firstcal ) THEN + debut = .TRUE. + IF (ngridmx.NE.2+(jjm-1)*iim) THEN + PRINT*,'STOP dans calfis' + PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim' + PRINT*,' ngridmx jjm iim ' + PRINT*,ngridmx,jjm,iim + STOP + ENDIF +c$OMP MASTER + ALLOCATE(zpsrf(klon)) + ALLOCATE(zplev(klon,llm+1),zplay(klon,llm)) + ALLOCATE(zphi(klon,llm),zphis(klon)) + ALLOCATE(zufi(klon,llm), zvfi(klon,llm)) + ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot)) + ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm)) + ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2)) + ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm)) + ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot)) + ALLOCATE(zdpsrf(klon)) + ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm)) + ALLOCATE(flxwfi(klon,llm)) +c$OMP END MASTER +c$OMP BARRIER + ELSE + debut = .FALSE. + ENDIF + +c +c +c----------------------------------------------------------------------- +c 40. transformation des variables dynamiques en variables physiques: +c --------------------------------------------------------------- + +c 41. pressions au sol (en Pascals) +c ---------------------------------- + +c$OMP MASTER + call start_timer(timer_physic) +c$OMP END MASTER + +c$OMP MASTER +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zpsrf(ig0)=pps(i,j) + enddo +c$OMP END MASTER + + +c 42. pression intercouches : +c +c ----------------------------------------------------------------- +c .... zplev definis aux (llm +1) interfaces des couches .... +c .... zplay definis aux ( llm ) milieux des couches .... +c ----------------------------------------------------------------- + +c ... Exner = cp * ( p(l) / preff ) ** kappa .... +c + unskap = 1./ kappa +c +c print *,omp_rank,'klon--->',klon +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llmp1 +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zplev( ig0,l ) = pp(i,j,l) + enddo + ENDDO +c$OMP END DO NOWAIT +c +c + +c 43. temperature naturelle (en K) et pressions milieux couches . +c --------------------------------------------------------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + pksurcp = ppk(i,j,l) / cpp + zplay(ig0,l) = preff * pksurcp ** unskap + ztfi(ig0,l) = pteta(i,j,l) * pksurcp + enddo + + ENDDO +c$OMP END DO NOWAIT + +c 43.bis traceurs +c --------------- +c + + DO iq=1,nqtot + iiq=niadv(iq) +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zqfi(ig0,l,iq) = pq(i,j,l,iiq) + enddo + ENDDO +c$OMP END DO NOWAIT + ENDDO + + +c Geopotentiel calcule par rapport a la surface locale: +c ----------------------------------------------------- + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zphi(ig0,l) = pphi(i,j,l) + enddo + ENDDO +c$OMP END DO NOWAIT + +c CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi) + +c$OMP MASTER +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + zphis(ig0) = pphis(i,j) + enddo +c$OMP END MASTER + + +c CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis) + +c$OMP BARRIER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ig=1,klon + zphi(ig,l)=zphi(ig,l)-zphis(ig) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + +c +c 45. champ u: +c ------------ + + kstart=1 + kend=klon + + if (is_north_pole) kstart=2 + if (is_south_pole) kend=klon-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) +!CDIR SPARSE + do ig0=kstart,kend + i=index_i(ig0) + j=index_j(ig0) + if (i==1) then + zufi(ig0,l)= 0.5 *( pucov(iim,j,l)/cu(iim,j) + $ + pucov(1,j,l)/cu(1,j) ) + else + zufi(ig0,l)= 0.5*( pucov(i-1,j,l)/cu(i-1,j) + $ + pucov(i,j,l)/cu(i,j) ) + endif + enddo + ENDDO +c$OMP END DO NOWAIT + +c 46.champ v: +c ----------- + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + DO ig0=kstart,kend + i=index_i(ig0) + j=index_j(ig0) + zvfi(ig0,l)= 0.5 *( pvcov(i,j-1,l)/cv(i,j-1) + $ + pvcov(i,j,l)/cv(i,j) ) + + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c 47. champs de vents aux pole nord +c ------------------------------ +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + if (is_north_pole) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zsin(i) = SIN(rlonv(i))*z1(i) + ENDDO + + zufi(1,l) = SSUM(iim,zcos,1)/pi + zvfi(1,l) = SSUM(iim,zsin,1)/pi + + ENDDO +c$OMP END DO NOWAIT + endif + + +c 48. champs de vents aux pole sud: +c --------------------------------- +c U = 1 / pi * integrale [ v * cos(long) * d long ] +c V = 1 / pi * integrale [ v * sin(long) * d long ] + + if (is_south_pole) then +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + z1(1) =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm) + DO i=2,iim + z1(i) =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm) + ENDDO + + DO i=1,iim + zcos(i) = COS(rlonv(i))*z1(i) + zsin(i) = SIN(rlonv(i))*z1(i) + ENDDO + + zufi(klon,l) = SSUM(iim,zcos,1)/pi + zvfi(klon,l) = SSUM(iim,zsin,1)/pi + ENDDO +c$OMP END DO NOWAIT + endif + + + IF (is_sequential) THEN +c +cIM calcul PV a teta=350, 380, 405K + CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta, + $ ztfi,zplay,zplev, + $ ntetaSTD,rtetaSTD,PVteta) +c + ENDIF + +c On change de grille, dynamique vers physiq, pour le flux de masse verticale +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm +!CDIR ON_ADB(index_i) +!CDIR ON_ADB(index_j) + do ig0=1,klon + i=index_i(ig0) + j=index_j(ig0) + flxwfi(ig0,l) = flxw(i,j,l) + enddo + ENDDO +c$OMP END DO NOWAIT + +c CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi) + +c----------------------------------------------------------------------- +c Appel de la physique: +c --------------------- + + +c$OMP BARRIER + if (first_omp) then + klon=klon_omp + + allocate(zplev_omp(klon,llm+1)) + allocate(zplay_omp(klon,llm)) + allocate(zphi_omp(klon,llm)) + allocate(zphis_omp(klon)) + allocate(presnivs_omp(llm)) + allocate(zufi_omp(klon,llm)) + allocate(zvfi_omp(klon,llm)) + allocate(ztfi_omp(klon,llm)) + allocate(zqfi_omp(klon,llm,nqtot)) + allocate(zdufi_omp(klon,llm)) + allocate(zdvfi_omp(klon,llm)) + allocate(zdtfi_omp(klon,llm)) + allocate(zdqfi_omp(klon,llm,nqtot)) + allocate(zdpsrf_omp(klon)) + allocate(flxwfi_omp(klon,llm)) + first_omp=.false. + endif + + + klon=klon_omp + offset=klon_omp_begin-1 + + do l=1,llm+1 + do i=1,klon + zplev_omp(i,l)=zplev(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zplay_omp(i,l)=zplay(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zphi_omp(i,l)=zphi(offset+i,l) + enddo + enddo + + do i=1,klon + zphis_omp(i)=zphis(offset+i) + enddo + + + do l=1,llm + presnivs_omp(l)=presnivs(l) + enddo + + do l=1,llm + do i=1,klon + zufi_omp(i,l)=zufi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zvfi_omp(i,l)=zvfi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + ztfi_omp(i,l)=ztfi(offset+i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq) + enddo + enddo + enddo + + do l=1,llm + do i=1,klon + zdufi_omp(i,l)=zdufi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdvfi_omp(i,l)=zdvfi(offset+i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdtfi_omp(i,l)=zdtfi(offset+i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq) + enddo + enddo + enddo + + do i=1,klon + zdpsrf_omp(i)=zdpsrf(offset+i) + enddo + + do l=1,llm + do i=1,klon + flxwfi_omp(i,l)=flxwfi(offset+i,l) + enddo + enddo + +c$OMP BARRIER + + if (planet_type=="earth") then +#ifdef CPP_EARTH + CALL physiq (klon, + . llm, + . debut, + . lafin, + . jD_cur, + . jH_cur, + . dtphys, + . zplev_omp, + . zplay_omp, + . zphi_omp, + . zphis_omp, + . presnivs_omp, + . clesphy0, + . zufi_omp, + . zvfi_omp, + . ztfi_omp, + . zqfi_omp, +c#ifdef INCA + . flxwfi_omp, +c#endif + . zdufi_omp, + . zdvfi_omp, + . zdtfi_omp, + . zdqfi_omp, + . zdpsrf_omp, +cIM diagnostique PVteta, Amip2 + . pducov, + . PVteta) +#endif + endif !of if (planet_type=="earth") +c$OMP BARRIER + + do l=1,llm+1 + do i=1,klon + zplev(offset+i,l)=zplev_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zplay(offset+i,l)=zplay_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zphi(offset+i,l)=zphi_omp(i,l) + enddo + enddo + + + do i=1,klon + zphis(offset+i)=zphis_omp(i) + enddo + + + do l=1,llm + presnivs(l)=presnivs_omp(l) + enddo + + do l=1,llm + do i=1,klon + zufi(offset+i,l)=zufi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zvfi(offset+i,l)=zvfi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + ztfi(offset+i,l)=ztfi_omp(i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq) + enddo + enddo + enddo + + do l=1,llm + do i=1,klon + zdufi(offset+i,l)=zdufi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdvfi(offset+i,l)=zdvfi_omp(i,l) + enddo + enddo + + do l=1,llm + do i=1,klon + zdtfi(offset+i,l)=zdtfi_omp(i,l) + enddo + enddo + + do iq=1,nqtot + do l=1,llm + do i=1,klon + zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq) + enddo + enddo + enddo + + do i=1,klon + zdpsrf(offset+i)=zdpsrf_omp(i) + enddo + + + klon=klon_mpi +500 CONTINUE +c$OMP BARRIER + +c$OMP MASTER + call stop_timer(timer_physic) +c$OMP END MASTER + + IF (using_mpi) THEN + + if (MPI_rank>0) then + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + du_send(1:iim,l)=zdufi(1:iim,l) + dv_send(1:iim,l)=zdvfi(1:iim,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER +#ifdef CPP_MPI +c$OMP MASTER +!$OMP CRITICAL (MPI) + call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401, + & COMM_LMDZ,Req(1),ierr) + call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402, + & COMM_LMDZ,Req(2),ierr) +!$OMP END CRITICAL (MPI) +c$OMP END MASTER +#endif +c$OMP BARRIER + + endif + + if (MPI_rank0 .and. MPI_rank< MPI_Size-1) then + call MPI_WAITALL(4,Req(1),Status,ierr) + else if (MPI_rank>0) then + call MPI_WAITALL(2,Req(1),Status,ierr) + else if (MPI_rank distrib_physic + + CALL allocate_u(ucov,llm,d) + CALL allocate_v(vcov,llm,d) + CALL allocate_u(teta,llm,d) + CALL allocate_u(masse,llm,d) + CALL allocate_u(ps,d) + CALL allocate_u(phis,d) + CALL allocate_u(q,llm,nqtot,d) + CALL allocate_u(flxw,llm,d) + CALL allocate_u(p,llmp1,d) + CALL allocate_u(alpha,llm,d) + CALL allocate_u(beta,llm,d) + CALL allocate_u(pks,d) + CALL allocate_u(pk,llm,d) + CALL allocate_u(pkf,llm,d) + CALL allocate_u(phi,llm,d) + CALL allocate_u(du,llm,d) + CALL allocate_v(dv,llm,d) + CALL allocate_u(dteta,llm,d) + CALL allocate_u(dq,llm,nqtot,d) + CALL allocate_u(dufi,llm,d) + CALL allocate_v(dvfi,llm,d) + CALL allocate_u(dtetafi,llm,d) + CALL allocate_u(dqfi,llm,nqtot,d) + CALL allocate_u(dpfi,d) + + END SUBROUTINE call_calfis_allocate + + + SUBROUTINE call_calfis(itau,lafin,clesphy0,ucov_dyn,vcov_dyn,teta_dyn,masse_dyn,ps_dyn, & + phis_dyn,q_dyn,flxw_dyn) + USE dimensions + USE parallel + USE times + USE mod_hallo + USE Bands + USE vampir + USE infotrac + USE control_mod + USE write_field_loc + USE write_field + IMPLICIT NONE + INCLUDE "comconst.h" + INCLUDE "comvert.h" + INCLUDE "logic.h" + INCLUDE "temps.h" + INCLUDE "iniprint.h" + + REAL :: clesphy0( : ) + INTEGER :: itau + LOGICAL :: lafin + REAL :: ucov_dyn(ijb_u:ije_u,llm) + REAL :: vcov_dyn(ijb_v:ije_v,llm) + REAL :: teta_dyn(ijb_u:ije_u,llm) + REAL :: masse_dyn(ijb_u:ije_u,llm) + REAL :: ps_dyn(ijb_u:ije_u) + REAL :: phis_dyn(ijb_u:ije_u) + REAL :: q_dyn(ijb_u:ije_u,llm,nqtot) + REAL :: flxw_dyn(ijb_u:ije_u,llm) + + REAL :: dufi_tmp(iip1,llm) + REAL :: dvfi_tmp(iip1,llm) + REAL :: dtetafi_tmp(iip1,llm) + REAL :: dpfi_tmp(iip1) + REAL :: dqfi_tmp(iip1,llm,nqtot) + + REAL :: jD_cur, jH_cur + CHARACTER(LEN=15) :: ztit + TYPE(Request) :: Request_physic + INTEGER :: ijb,ije,l,j + + +#ifdef DEBUG_IO + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('pfi',p) + CALL WriteField_u('pkfi',pk) + DO j=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) + ENDDO +#endif + +! +! ....... Ajout P.Le Van ( 17/04/96 ) ........... +! + + + !$OMP MASTER + CALL suspend_timer(timer_caldyn) + WRITE(lunout,*) 'leapfrog_p: Entree dans la physique : Iteration No ',itau + !$OMP END MASTER + + jD_cur = jD_ref + day_ini - day_ref + int (itau * dtvr / daysec) + jH_cur = jH_ref + (itau * dtvr / daysec - int(itau * dtvr / daysec)) + +! Inbterface avec les routines de phylmd (phymars ... ) +! ----------------------------------------------------- + +!+jld + +! Diagnostique de conservation de l'energie : initialisation + +!-jld + !$OMP BARRIER + !$OMP MASTER + CALL VTb(VThallo) + !$OMP END MASTER + +#ifdef DEBUG_IO + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('pfi',p) + CALL WriteField_u('pkfi',pk) +#endif + + CALL SetTag(Request_physic,800) + CALL Register_SwapField_u(ucov_dyn,ucov,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_v(vcov_dyn,vcov,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_u(teta_dyn,teta,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_u(masse_dyn,masse,distrib_physic,Request_physic,up=1,down=2) + CALL Register_SwapField_u(ps_dyn,ps,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_u(phis_dyn,phis,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_u(q_dyn,q,distrib_physic,Request_physic,up=2,down=2) + CALL Register_SwapField_u(flxw_dyn,flxw,distrib_physic,Request_physic,up=2,down=2) + + CALL SendRequest(Request_Physic) + !$OMP BARRIER + CALL WaitRequest(Request_Physic) + + !$OMP BARRIER + !$OMP MASTER + CALL Set_Distrib(distrib_Physic) + CALL VTe(VThallo) + + CALL VTb(VTphysiq) + !$OMP END MASTER + !$OMP BARRIER + + CALL pression_loc ( ip1jmp1, ap, bp, ps, p ) + + !$OMP BARRIER + CALL exner_hyb_loc( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + !$OMP BARRIER + CALL geopot_loc ( ip1jmp1, teta , pk , pks, phis , phi ) + + + CALL Register_Hallo_u(p,llmp1,2,2,2,2,Request_physic) + CALL Register_Hallo_u(pk,llm,2,2,2,2,Request_physic) + CALL Register_Hallo_u(phi,llm,2,2,2,2,Request_physic) + + CALL SendRequest(Request_Physic) + !$OMP BARRIER + CALL WaitRequest(Request_Physic) + + !$OMP BARRIER + + +#ifdef DEBUG_IO + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('pfi',p) + CALL WriteField_u('pkfi',pk) + DO j=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) + ENDDO +#endif + + !$OMP BARRIER + + CALL calfis_loc(lafin ,jD_cur, jH_cur, & + ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , & + du,dv,dteta,dq, & + flxw, & + clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi ) + + ijb=ij_begin + ije=ij_end + IF ( .not. pole_nord) THEN + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dufi_tmp(1:iip1,l) = dufi(ijb:ijb+iim,l) + dvfi_tmp(1:iip1,l) = dvfi(ijb:ijb+iim,l) + dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l) + dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:) + ENDDO + !$OMP END DO NOWAIT + + !$OMP MASTER + dpfi_tmp(1:iip1) = dpfi(ijb:ijb+iim) + !$OMP END MASTER + + ENDIF ! of if ( .not. pole_nord) + + !$OMP BARRIER + !$OMP MASTER + CALL Set_Distrib(distrib_Physic_bis) + CALL VTb(VThallo) + !$OMP END MASTER + !$OMP BARRIER + + CALL Register_Hallo_u(dufi,llm,1,0,0,1,Request_physic) + CALL Register_Hallo_v(dvfi,llm,1,0,0,1,Request_physic) + CALL Register_Hallo_u(dtetafi,llm,1,0,0,1,Request_physic) + CALL Register_Hallo_u(dpfi,1,1,0,0,1,Request_physic) + + DO j=1,nqtot + CALL Register_Hallo_u(dqfi(:,:,j),llm,1,0,0,1,Request_physic) + ENDDO + + CALL SendRequest(Request_Physic) + !$OMP BARRIER + CALL WaitRequest(Request_Physic) + + !$OMP BARRIER + !$OMP MASTER + CALL VTe(VThallo) + CALL Set_Distrib(distrib_Physic) + !$OMP END MASTER + !$OMP BARRIER + ijb=ij_begin + IF (.not. pole_nord) THEN + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l) + dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l) + dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l)+dtetafi_tmp(1:iip1,l) + dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) + dqfi_tmp(1:iip1,l,:) + ENDDO + !$OMP END DO NOWAIT + + !$OMP MASTER + dpfi(ijb:ijb+iim) = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1) + !$OMP END MASTER + + endif ! of if (.not. pole_nord) + + +#ifdef DEBUG_IO + CALL WriteField_u('dufi',dufi) + CALL WriteField_v('dvfi',dvfi) + CALL WriteField_u('dtetafi',dtetafi) + CALL WriteField_u('dpfi',dpfi) + DO j=1,nqtot + CALL WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j)) + ENDDO +#endif + + !$OMP BARRIER + +! ajout des tendances physiques: +! ------------------------------ +#ifdef DEBUG_IO + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('psfi',ps) + DO j=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) + ENDDO +#endif + + IF (ok_strato) THEN + CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi) + ENDIF + +#ifdef DEBUG_IO + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('psfi',ps) + DO j=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) + ENDDO +#endif + + CALL addfi_loc( dtphys, leapf, forward , & + ucov, vcov, teta , q ,ps , & + dufi, dvfi, dtetafi , dqfi ,dpfi ) + +#ifdef DEBUG_IO + CALL WriteField_u('ucovfi',ucov) + CALL WriteField_v('vcovfi',vcov) + CALL WriteField_u('tetafi',teta) + CALL WriteField_u('psfi',ps) + DO j=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) + ENDDO +#endif + + !$OMP BARRIER + !$OMP MASTER + CALL VTe(VTphysiq) + CALL VTb(VThallo) + !$OMP END MASTER + + CALL SetTag(Request_physic,800) + CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_physic) + CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_physic) + CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_physic) + CALL Register_SwapField_u(masse,masse_dyn,distrib_caldyn,Request_physic) + CALL Register_SwapField_u(ps,ps_dyn,distrib_caldyn,Request_physic) + CALL Register_SwapField_u(q,q_dyn,distrib_caldyn,Request_physic) + CALL SendRequest(Request_Physic) + !$OMP BARRIER + CALL WaitRequest(Request_Physic) + + !$OMP BARRIER + !$OMP MASTER + CALL VTe(VThallo) + CALL set_distrib(distrib_caldyn) + !$OMP END MASTER + !$OMP BARRIER + +! +! Diagnostique de conservation de l'energie : difference + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil phys' + CALL diagedyn(ztit,2,1,1,dtphys,ucov, vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF + +#ifdef DEBUG_IO + CALL WriteField_u('ucovfi',ucov_dyn) + CALL WriteField_v('vcovfi',vcov_dyn) + CALL WriteField_u('tetafi',teta_dyn) + CALL WriteField_u('psfi',ps_dyn) + DO j=1,nqtot + CALL WriteField_u('qfi'//trim(int2str(j)),q_dyn(:,:,j)) + ENDDO +#endif + + +!-jld + !$OMP MASTER + CALL resume_timer(timer_caldyn) + !$OMP END MASTER + + END SUBROUTINE call_calfis + +END MODULE call_calfis_mod Index: /LMDZ5/trunk/libf/dyn3dmem/call_dissip_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/call_dissip_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/call_dissip_mod.F90 (revision 1632) @@ -0,0 +1,313 @@ +MODULE call_dissip_mod + + REAL,POINTER,SAVE :: ucov(:,:) + REAL,POINTER,SAVE :: vcov(:,:) + REAL,POINTER,SAVE :: teta(:,:) + REAL,POINTER,SAVE :: p(:,: ) + REAL,POINTER,SAVE :: pk(:,:) + + REAL,POINTER,SAVE :: ucont(:,:) + REAL,POINTER,SAVE :: vcont(:,:) + REAL,POINTER,SAVE :: ecin(:,:) + REAL,POINTER,SAVE :: ecin0(:,:) + REAL,POINTER,SAVE :: dudis(:,:) + REAL,POINTER,SAVE :: dvdis(:,:) + REAL,POINTER,SAVE :: dtetadis(:,:) + REAL,POINTER,SAVE :: dtetaecdt(:,:) + + + +CONTAINS + + SUBROUTINE call_dissip_allocate + USE bands + USE allocate_field + USE parallel + USE dimensions + USE dissip_mod, ONLY : dissip_allocate + IMPLICIT NONE + TYPE(distrib),POINTER :: d + d=>distrib_dissip + + CALL allocate_u(ucov,llm,d) + CALL allocate_v(vcov,llm,d) + CALL allocate_u(teta,llm,d) + CALL allocate_u(p,llmp1,d) + CALL allocate_u(pk,llm,d) + CALL allocate_u(ucont,llm,d) + CALL allocate_v(vcont,llm,d) + CALL allocate_u(ecin,llm,d) + CALL allocate_u(ecin0,llm,d) + CALL allocate_u(dudis,llm,d) + CALL allocate_v(dvdis,llm,d) + CALL allocate_u(dtetadis,llm,d) + CALL allocate_u(dtetaecdt,llm,d) + + + CALL dissip_allocate + + END SUBROUTINE call_dissip_allocate + + SUBROUTINE call_dissip_switch_dissip(dist) + USE allocate_field + USE bands + USE parallel + USE dissip_mod, ONLY : dissip_switch_dissip + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(ucov,distrib_dissip,dist) + CALL switch_v(vcov,distrib_dissip,dist) + CALL switch_u(teta,distrib_dissip,dist) + CALL switch_u(p,distrib_dissip,dist) + CALL switch_u(pk,distrib_dissip,dist) + CALL switch_u(ucont,distrib_dissip,dist) + CALL switch_v(vcont,distrib_dissip,dist) + CALL switch_u(ecin,distrib_dissip,dist) + CALL switch_u(ecin0,distrib_dissip,dist) + CALL switch_u(dudis,distrib_dissip,dist) + CALL switch_v(dvdis,distrib_dissip,dist) + CALL switch_u(dtetadis,distrib_dissip,dist) + CALL switch_u(dtetaecdt,distrib_dissip,dist) + + CALL dissip_switch_dissip(dist) + + END SUBROUTINE call_dissip_switch_dissip + + + + SUBROUTINE call_dissip(ucov_dyn,vcov_dyn,teta_dyn,p_dyn,pk_dyn,ps_dyn) + USE dimensions + USE parallel + USE times + USE mod_hallo + USE Bands + USE vampir + USE write_field_loc + IMPLICIT NONE + INCLUDE 'comgeom.h' + REAL :: ucov_dyn(ijb_u:ije_u,llm) + REAL :: vcov_dyn(ijb_v:ije_v,llm) + REAL :: teta_dyn(ijb_u:ije_u,llm) + REAL :: p_dyn(ijb_u:ije_u,llmp1 ) + REAL :: pk_dyn(ijb_u:ije_u,llm) + REAL :: ps_dyn(ijb_u:ije_u) + REAL :: tppn(iim),tpps(iim) + REAL :: tpn,tps + + REAL SSUM + LOGICAL,PARAMETER :: dissip_conservative=.TRUE. + TYPE(Request) :: Request_dissip + + INTEGER :: ij,l,ijb,ije + + + !$OMP MASTER + CALL suspend_timer(timer_caldyn) + +! print*,'Entree dans la dissipation : Iteration No ',true_itau +! calcul de l'energie cinetique avant dissipation +! print *,'Passage dans la dissipation' + + CALL VTb(VThallo) + !$OMP END MASTER + + !$OMP BARRIER + + CALL Register_SwapField_u(ucov_dyn,ucov,distrib_dissip, Request_dissip,up=1,down=1) + CALL Register_SwapField_v(vcov_dyn,vcov,distrib_dissip, Request_dissip,up=1,down=1) + CALL Register_SwapField_u(teta_dyn,teta,distrib_dissip, Request_dissip) + CALL Register_SwapField_u(p_dyn,p,distrib_dissip,Request_dissip) + CALL Register_SwapField_u(pk_dyn,pk,distrib_dissip,Request_dissip) + + CALL SendRequest(Request_dissip) + !$OMP BARRIER + CALL WaitRequest(Request_dissip) + + !$OMP BARRIER + !$OMP MASTER + CALL set_distrib(distrib_dissip) + CALL VTe(VThallo) + CALL VTb(VTdissipation) + CALL start_timer(timer_dissip) + !$OMP END MASTER + !$OMP BARRIER + + CALL covcont_loc(llm,ucov,vcov,ucont,vcont) + CALL enercin_loc(vcov,ucov,vcont,ucont,ecin0) + +! dissipation + +! CALL FTRACE_REGION_BEGIN("dissip") + CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis) + +#ifdef DEBUG_IO + CALL WriteField_u('dudis',dudis) + CALL WriteField_v('dvdis',dvdis) + CALL WriteField_u('dtetadis',dtetadis) +#endif + +! CALL FTRACE_REGION_END("dissip") + + ijb=ij_begin + ije=ij_end + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l) + ENDDO + !$OMP END DO NOWAIT + + IF (pole_sud) ije=ije-iip1 + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l) + ENDDO + !$OMP END DO NOWAIT + +! teta=teta+dtetadis + + +!------------------------------------------------------------------------ + IF (dissip_conservative) THEN +! On rajoute la tendance due a la transform. Ec -> E therm. cree +! lors de la dissipation + !$OMP BARRIER + !$OMP MASTER + CALL suspend_timer(timer_dissip) + CALL VTb(VThallo) + !$OMP END MASTER + CALL Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip) + CALL Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip) + CALL SendRequest(Request_Dissip) + !$OMP BARRIER + CALL WaitRequest(Request_Dissip) + !$OMP MASTER + CALL VTe(VThallo) + CALL resume_timer(timer_dissip) + !$OMP END MASTER + !$OMP BARRIER + CALL covcont_loc(llm,ucov,vcov,ucont,vcont) + CALL enercin_loc(vcov,ucov,vcont,ucont,ecin) + + ijb=ij_begin + ije=ij_end + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l) + dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l) + ENDDO + ENDDO + !$OMP END DO NOWAIT + + ENDIF + + ijb=ij_begin + ije=ij_end + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + teta(ij,l)=teta(ij,l)+dtetadis(ij,l) + ENDDO + ENDDO + !$OMP END DO NOWAIT + +!------------------------------------------------------------------------ + + +! ....... P. Le Van ( ajout le 17/04/96 ) ........... +! ... Calcul de la valeur moyenne, unique de h aux poles ..... +! + + ijb=ij_begin + ije=ij_end + + IF (pole_nord) THEN + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = 1,iim + tppn(ij) = aire( ij ) * teta( ij ,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + + DO ij = 1, iip1 + teta( ij ,l) = tpn + ENDDO + ENDDO + !$OMP END DO NOWAIT + + !$OMP MASTER + DO ij = 1,iim + tppn(ij) = aire( ij ) * ps_dyn ( ij ) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + + DO ij = 1, iip1 + ps_dyn( ij ) = tpn + ENDDO + !$OMP END MASTER + + ENDIF + + IF (pole_sud) THEN + + !$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = 1,iim + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta(ij+ip1jm,l) = tps + ENDDO + ENDDO + !$OMP END DO NOWAIT + + !$OMP MASTER + DO ij = 1,iim + tpps(ij) = aire(ij+ip1jm) * ps_dyn (ij+ip1jm) + ENDDO + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + ps_dyn(ij+ip1jm) = tps + ENDDO + !$OMP END MASTER + ENDIF + + + !$OMP BARRIER + !$OMP MASTER + CALL VTe(VTdissipation) + CALL stop_timer(timer_dissip) + CALL VTb(VThallo) + !$OMP END MASTER + + CALL Register_SwapField_u(ucov,ucov_dyn,distrib_caldyn,Request_dissip) + CALL Register_SwapField_v(vcov,vcov_dyn,distrib_caldyn,Request_dissip) + CALL Register_SwapField_u(teta,teta_dyn,distrib_caldyn,Request_dissip) + CALL Register_SwapField_u(p,p_dyn,distrib_caldyn,Request_dissip) + CALL Register_SwapField_u(pk,pk_dyn,distrib_caldyn,Request_dissip) + + CALL SendRequest(Request_dissip) + + !$OMP BARRIER + CALL WaitRequest(Request_dissip) + !$OMP BARRIER + !$OMP MASTER + CALL set_distrib(distrib_caldyn) + CALL VTe(VThallo) + CALL resume_timer(timer_caldyn) +! print *,'fin dissipation' + !$OMP END MASTER + !$OMP BARRIER + + + END SUBROUTINE call_dissip + +END MODULE call_dissip_mod Index: /LMDZ5/trunk/libf/dyn3dmem/clesph0.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/clesph0.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/clesph0.h (revision 1632) @@ -0,0 +1,11 @@ +! +! $Header$ +! +c..include clesph0.h +c + COMMON/clesph0/cycle_diurne, soil_model,new_oliq, ok_orodr , + , ok_orolf ,ok_limitvrai, nbapp_rad, iflag_con +c + LOGICAL cycle_diurne,soil_model,ok_orodr,ok_orolf,new_oliq + LOGICAL ok_limitvrai + INTEGER nbapp_rad, iflag_con Index: /LMDZ5/trunk/libf/dyn3dmem/coefpoly.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/coefpoly.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/coefpoly.F (revision 1632) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE coefpoly ( Xf1, Xf2, Xprim1, Xprim2, xtild1,xtild2 , + , a0,a1,a2,a3 ) + IMPLICIT NONE +c +c ... Auteur : P. Le Van ... +c +c +c Calcul des coefficients a0, a1, a2, a3 du polynome de degre 3 qui +c satisfait aux 4 equations suivantes : + +c a0 + a1*xtild1 + a2*xtild1*xtild1 + a3*xtild1*xtild1*xtild1 = Xf1 +c a0 + a1*xtild2 + a2*xtild2*xtild2 + a3*xtild2*xtild2*xtild2 = Xf2 +c a1 + 2.*a2*xtild1 + 3.*a3*xtild1*xtild1 = Xprim1 +c a1 + 2.*a2*xtild2 + 3.*a3*xtild2*xtild2 = Xprim2 + +c On en revient a resoudre un systeme de 4 equat.a 4 inconnues a0,a1,a2,a3 + + REAL(KIND=8) Xf1, Xf2,Xprim1,Xprim2, xtild1,xtild2, xi + REAL(KIND=8) Xfout, Xprim + REAL(KIND=8) a1,a2,a3,a0, xtil1car, xtil2car,derr,x1x2car + + xtil1car = xtild1 * xtild1 + xtil2car = xtild2 * xtild2 + + derr= 2. *(Xf2-Xf1)/( xtild1-xtild2) + + x1x2car = ( xtild1-xtild2)*(xtild1-xtild2) + + a3 = (derr + Xprim1+Xprim2 )/x1x2car + a2 = ( Xprim1 - Xprim2 + 3.* a3 * ( xtil2car-xtil1car ) ) / + / ( 2.* ( xtild1 - xtild2 ) ) + + a1 = Xprim1 -3.* a3 * xtil1car -2.* a2 * xtild1 + a0 = Xf1 - a3 * xtild1* xtil1car -a2 * xtil1car - a1 *xtild1 + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/com_io_dyn.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/com_io_dyn.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/com_io_dyn.h (revision 1632) @@ -0,0 +1,5 @@ +! +! $Header$ +! + integer histid, histvid, histaveid + common/com_io_dyn/histid, histvid, histaveid Index: /LMDZ5/trunk/libf/dyn3dmem/com_io_dyn_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/com_io_dyn_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/com_io_dyn_mod.F90 (revision 1632) @@ -0,0 +1,31 @@ +! +! $Id $ +! +module com_io_dyn_mod + + implicit none + +! Names of various files for outputs (in the dynamics) + ! to store instantaneous values: + character(len=18),parameter :: dynhist_file="dyn_hist.nc" ! on scalar grid + character(len=18),parameter :: dynhistv_file="dyn_histv.nc" ! on v grid + character(len=18),parameter :: dynhistu_file="dyn_histu.nc" ! on u grid + + ! to store averaged values: + character(len=18),parameter :: dynhistave_file="dyn_hist_ave.nc" + character(len=18),parameter :: dynhistvave_file="dyn_histv_ave.nc" + character(len=18),parameter :: dynhistuave_file="dyn_histu_ave.nc" + +! Ids of various files for outputs (in the dynamics) + + ! instantaneous (these are set by inithist.F) + integer :: histid + integer :: histvid + integer :: histuid + + ! averages (these are set by initdynav.F) + integer :: histaveid + integer :: histvaveid + integer :: histuaveid + +end module com_io_dyn_mod Index: /LMDZ5/trunk/libf/dyn3dmem/comconst.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/comconst.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/comconst.h (revision 1632) @@ -0,0 +1,23 @@ +! +! $Id: comconst.h 1279 2009-12-10 09:02:56Z fairhead $ +! +!----------------------------------------------------------------------- +! INCLUDE comconst.h + + COMMON/comconst/im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl, & + & dtvr,daysec, & + & pi,dtphys,dtdiss,rad,r,cpp,kappa,cotot,unsim,g,omeg & + & ,dissip_factz,dissip_deltaz,dissip_zref & + & ,iflag_top_bound,tau_top_bound + + + INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl + REAL dtvr,daysec + REAL pi,dtphys,dtdiss,rad,r,cpp,kappa + REAL cotot,unsim,g,omeg + REAL dissip_factz,dissip_deltaz,dissip_zref + INTEGER iflag_top_bound + REAL tau_top_bound + + +!----------------------------------------------------------------------- Index: /LMDZ5/trunk/libf/dyn3dmem/comdissip.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/comdissip.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/comdissip.h (revision 1632) @@ -0,0 +1,15 @@ +! +! $Header$ +! +!----------------------------------------------------------------------- +! INCLUDE comdissip.h + + COMMON/comdissip/ & + & niterdis,coefdis,tetavel,tetatemp,gamdissip + + + INTEGER niterdis + + REAL tetavel,tetatemp,coefdis,gamdissip + +!----------------------------------------------------------------------- Index: /LMDZ5/trunk/libf/dyn3dmem/comdissipn.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/comdissipn.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/comdissipn.h (revision 1632) @@ -0,0 +1,16 @@ +! +! $Header$ +! +c----------------------------------------------------------------------- +c INCLUDE comdissipn.h + + REAL tetaudiv, tetaurot, tetah, cdivu, crot, cdivh +c + COMMON/comdissipn/ tetaudiv(llm),tetaurot(llm),tetah(llm) , + 1 cdivu, crot, cdivh + +c +c Les parametres de ce common proviennent des calculs effectues dans +c Inidissip . +c +c----------------------------------------------------------------------- Index: /LMDZ5/trunk/libf/dyn3dmem/comdissnew.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/comdissnew.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/comdissnew.h (revision 1632) @@ -0,0 +1,18 @@ +! +! $Header$ +! +!----------------------------------------------------------------------- +! INCLUDE comdissnew.h + + COMMON/comdissnew/ lstardis,nitergdiv,nitergrot,niterh,tetagdiv, & + & tetagrot,tetatemp,coefdis + + LOGICAL lstardis + INTEGER nitergdiv, nitergrot, niterh + 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/dyn3dmem/comgeom.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/comgeom.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/comgeom.h (revision 1632) @@ -0,0 +1,33 @@ +! +! $Header$ +! +!CDK comgeom + COMMON/comgeom/ & + & cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm), & + & aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1), & + & airev(ip1jm),unsaire(ip1jmp1),apoln,apols, & + & unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm), & + & aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1), & + & aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1), & + & alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1), & + & alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1), & + & fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm), & + & rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm), & + & cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm), & + & cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1), & + & cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1), & + & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2, & + & unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm), & + & aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1) + +! + REAL & + & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln ,& + & apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,& + & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,& + & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 ,& + & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2& + & ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam ,& + & aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu& + & , xprimv +! Index: /LMDZ5/trunk/libf/dyn3dmem/comgeom2.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/comgeom2.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/comgeom2.h (revision 1632) @@ -0,0 +1,33 @@ +! +! $Header$ +! +!CDK comgeom2 + COMMON/comgeom/ & + & cu(iip1,jjp1),cv(iip1,jjm),unscu2(iip1,jjp1),unscv2(iip1,jjm) , & + & aire(iip1,jjp1),airesurg(iip1,jjp1),aireu(iip1,jjp1) , & + & airev(iip1,jjm),unsaire(iip1,jjp1),apoln,apols , & + & unsairez(iip1,jjm),airuscv2(iip1,jjm),airvscu2(iip1,jjm) , & + & aireij1(iip1,jjp1),aireij2(iip1,jjp1),aireij3(iip1,jjp1) , & + & aireij4(iip1,jjp1),alpha1(iip1,jjp1),alpha2(iip1,jjp1) , & + & alpha3(iip1,jjp1),alpha4(iip1,jjp1),alpha1p2(iip1,jjp1) , & + & alpha1p4(iip1,jjp1),alpha2p3(iip1,jjp1),alpha3p4(iip1,jjp1) , & + & fext(iip1,jjm),constang(iip1,jjp1), rlatu(jjp1),rlatv(jjm), & + & rlonu(iip1),rlonv(iip1),cuvsurcv(iip1,jjm),cvsurcuv(iip1,jjm) , & + & cvusurcu(iip1,jjp1),cusurcvu(iip1,jjp1) , & + & cuvscvgam1(iip1,jjm),cuvscvgam2(iip1,jjm),cvuscugam1(iip1,jjp1), & + & cvuscugam2(iip1,jjp1),cvscuvgam(iip1,jjm),cuscvugam(iip1,jjp1) , & + & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2 , & + & unsair_gam1(iip1,jjp1),unsair_gam2(iip1,jjp1) , & + & unsairz_gam(iip1,jjm),aivscu2gam(iip1,jjm),aiuscv2gam(iip1,jjm) & + & , xprimu(iip1),xprimv(iip1) + + + REAL & + & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,apoln,apols,unsaire & + & ,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4 , & + & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 , & + & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2 , & + & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1 , & + & unsapolnga2,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2 , & + & unsairz_gam,aivscu2gam,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu , & + & cusurcvu,xprimu,xprimv Index: /LMDZ5/trunk/libf/dyn3dmem/comvert.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/comvert.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/comvert.h (revision 1632) @@ -0,0 +1,19 @@ +! +! $Header$ +! +!----------------------------------------------------------------------- +! INCLUDE 'comvert.h' + + COMMON/comvert/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm), & + & pa,preff,nivsigs(llm),nivsig(llm+1) + + common/comverti/disvert_type + + REAL ap,bp,presnivs,dpres,pa,preff,nivsigs,nivsig + + 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 +!----------------------------------------------------------------------- Index: /LMDZ5/trunk/libf/dyn3dmem/conf_dat2d.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/conf_dat2d.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/conf_dat2d.F (revision 1632) @@ -0,0 +1,221 @@ +! +! $Header$ +! +C +C + SUBROUTINE conf_dat2d( title,lons,lats,xd,yd,xf,yf,champd , + , interbar ) +c +c Auteur : P. Le Van + +c Ce s-pr. configure le champ de donnees 2D 'champd' de telle facon que +c qu'on ait - pi a pi en longitude +c et qu'on ait pi/2. a - pi/2. en latitude +c +c xd et yd sont les longitudes et latitudes initiales +c xf et yf sont les longitudes et latitudes en sortie , eventuellement +c modifiees pour etre configurees comme ci-dessus . + + IMPLICIT NONE + +c *** Arguments en entree *** + INTEGER lons,lats + CHARACTER*25 title + REAL xd(lons),yd(lats) + LOGICAL interbar +c +c *** Arguments en sortie *** + REAL xf(lons),yf(lats) +c +c *** Arguments en entree et sortie *** + REAL champd(lons,lats) + +c *** Variables locales *** +c + REAL pi,pis2,depi + LOGICAL radianlon, invlon ,radianlat, invlat, alloc + REAL rlatmin,rlatmax,oldxd1 + INTEGER i,j,ip180,ind + + REAL, ALLOCATABLE :: xtemp(:) + REAL, ALLOCATABLE :: ytemp(:) + REAL, ALLOCATABLE :: champf(:,:) + +c +c WRITE(6,*) ' conf_dat2d pour la variable ', title + + ALLOCATE( xtemp(lons) ) + ALLOCATE( ytemp(lats) ) + ALLOCATE( champf(lons,lats) ) + + DO i = 1, lons + xtemp(i) = xd(i) + ENDDO + DO j = 1, lats + ytemp(j) = yd(j) + ENDDO + + pi = 2. * ASIN(1.) + pis2 = pi/2. + depi = 2. * pi + + radianlon = .FALSE. + IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN + radianlon = .TRUE. + invlon = .FALSE. + ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN + radianlon = .TRUE. + invlon = .TRUE. + ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN + radianlon = .FALSE. + invlon = .FALSE. + ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN + radianlon = .FALSE. + invlon = .TRUE. + ELSE + WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' + , , title + ENDIF + + invlat = .FALSE. + + IF( ytemp(1).LT.ytemp(lats) ) THEN + invlat = .TRUE. + ENDIF + + rlatmin = MIN( ytemp(1), ytemp(lats) ) + rlatmax = MAX( ytemp(1), ytemp(lats) ) + + IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN + radianlat = .TRUE. + ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN + radianlat = .FALSE. + ELSE + WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' + , , title + ENDIF + + IF( .NOT. radianlon ) THEN + DO i = 1, lons + xtemp(i) = xtemp(i) * pi/180. + ENDDO + ENDIF + + IF( .NOT. radianlat ) THEN + DO j = 1, lats + ytemp(j) = ytemp(j) * pi/180. + ENDDO + ENDIF + + + IF ( invlon ) THEN + + DO j = 1, lats + DO i = 1,lons + champf(i,j) = champd(i,j) + ENDDO + ENDDO + + DO i = 1 ,lons + xf(i) = xtemp(i) + ENDDO +c +c *** On tourne les longit. pour avoir - pi a + pi **** +c + DO i=1,lons + IF( xf(i).GT. pi ) THEN + GO TO 88 + ENDIF + ENDDO + +88 CONTINUE +c + ip180 = i + + DO i = 1,lons + IF (xf(i).GT. pi) THEN + xf(i) = xf(i) - depi + ENDIF + ENDDO + + DO i= ip180,lons + ind = i-ip180 +1 + xtemp(ind) = xf(i) + ENDDO + + DO i= ind +1,lons + xtemp(i) = xf(i-ind) + ENDDO + +c ..... on tourne les longitudes pour champf .... +c + DO j = 1,lats + + DO i = ip180,lons + ind = i-ip180 +1 + champd (ind,j) = champf (i,j) + ENDDO + + DO i= ind +1,lons + champd (i,j) = champf (i-ind,j) + ENDDO + + ENDDO + + + ENDIF +c +c ***** fin de IF(invlon) **** + + IF ( invlat ) THEN + + DO j = 1,lats + yf(j) = ytemp(j) + ENDDO + + DO j = 1, lats + DO i = 1,lons + champf(i,j) = champd(i,j) + ENDDO + ENDDO + + DO j = 1, lats + ytemp( lats-j+1 ) = yf(j) + DO i = 1, lons + champd (i,lats-j+1) = champf (i,j) + ENDDO + ENDDO + + + ENDIF + +c ***** fin de IF(invlat) **** + +c + IF( interbar ) THEN + oldxd1 = xtemp(1) + DO i = 1, lons -1 + xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) + ENDDO + xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) + + DO j = 1, lats -1 + ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) + ENDDO + + ENDIF +c + DEALLOCATE(champf) + + DO i = 1, lons + xf(i) = xtemp(i) + ENDDO + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + + deallocate(xtemp) + deallocate(ytemp) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/conf_dat3d.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/conf_dat3d.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/conf_dat3d.F (revision 1632) @@ -0,0 +1,296 @@ +! +! $Header$ +! +C +C + SUBROUTINE conf_dat3d( title, lons,lats,levs,xd,yd,zd,xf,yf,zf, + , champd , interbar ) +c +c Auteur : P. Le Van +c +c Ce s-pr. configure le champ de donnees 3D 'champd' de telle facon +c qu'on ait - pi a pi en longitude +c qu'on ait pi/2. a - pi/2. en latitude +c et qu'on ait les niveaux verticaux variant du sol vers le ht de l'atmos. +c ( en Pascals ) . +c +c xd et yd sont les longitudes et latitudes initiales +c zd les pressions initiales +c +c xf et yf sont les longitudes et latitudes en sortie , eventuellement +c modifiees pour etre configurees comme ci-dessus . +c zf les pressions en sortie +c +c champd en meme temps le champ initial et final +c +c interbar = .TRUE. si on appelle l'interpo. barycentrique inter_barxy +c sinon , l'interpolation grille_m ( grid_atob ) . +c + + IMPLICIT NONE + +c *** Arguments en entree *** + CHARACTER*(*) :: title + INTEGER lons, lats, levs + REAL xd(lons), yd(lats), zd(levs) + LOGICAL interbar +c +c *** Arguments en sortie *** + REAL xf(lons), yf(lats), zf(levs) + +c *** Arguments en entree et sortie *** + REAL champd(lons,lats,levs) + +c *** Variables locales *** +c + REAL pi,pis2,depi,presmax + LOGICAL radianlon, invlon ,radianlat, invlat, invlev, alloc + REAL rlatmin,rlatmax,oldxd1 + INTEGER i,j,ip180,ind,l + + REAL, ALLOCATABLE :: xtemp(:) + REAL, ALLOCATABLE :: ytemp(:) + REAL, ALLOCATABLE :: ztemp(:) + REAL, ALLOCATABLE :: champf(:,:,:) + + +c WRITE(6,*) ' Conf_dat3d pour ',title + + ALLOCATE(xtemp(lons)) + ALLOCATE(ytemp(lats)) + ALLOCATE(ztemp(levs)) + + DO i = 1, lons + xtemp(i) = xd(i) + ENDDO + DO j = 1, lats + ytemp(j) = yd(j) + ENDDO + DO l = 1, levs + ztemp(l) = zd(l) + ENDDO + + pi = 2. * ASIN(1.) + pis2 = pi/2. + depi = 2. * pi + + IF( xtemp(1).GE.-pi-0.5.AND. xtemp(lons).LE.pi+0.5 ) THEN + radianlon = .TRUE. + invlon = .FALSE. + ELSE IF (xtemp(1).GE.-0.5.AND.xtemp(lons).LE.depi+0.5 ) THEN + radianlon = .TRUE. + invlon = .TRUE. + ELSE IF ( xtemp(1).GE.-180.5.AND. xtemp(lons).LE.180.5 ) THEN + radianlon = .FALSE. + invlon = .FALSE. + ELSE IF ( xtemp(1).GE.-0.5.AND.xtemp(lons).LE.360.5 ) THEN + radianlon = .FALSE. + invlon = .TRUE. + ELSE + WRITE(6,*) 'Pbs. sur les longitudes des donnees pour le fichier' + , , title + ENDIF + + invlat = .FALSE. + + IF( ytemp(1).LT.ytemp(lats) ) THEN + invlat = .TRUE. + ENDIF + + rlatmin = MIN( ytemp(1), ytemp(lats) ) + rlatmax = MAX( ytemp(1), ytemp(lats) ) + + IF( rlatmin.GE.-pis2-0.5.AND.rlatmax.LE.pis2+0.5)THEN + radianlat = .TRUE. + ELSE IF ( rlatmin.GE.-90.-0.5.AND.rlatmax.LE.90.+0.5 ) THEN + radianlat = .FALSE. + ELSE + WRITE(6,*) ' Pbs. sur les latitudes des donnees pour le fichier' + , , title + ENDIF + + IF( .NOT. radianlon ) THEN + DO i = 1, lons + xtemp(i) = xtemp(i) * pi/180. + ENDDO + ENDIF + + IF( .NOT. radianlat ) THEN + DO j = 1, lats + ytemp(j) = ytemp(j) * pi/180. + ENDDO + ENDIF + + + alloc =.FALSE. + + IF ( invlon ) THEN + + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + + DO i = 1 ,lons + xf(i) = xtemp(i) + ENDDO + + DO l = 1, levs + DO j = 1, lats + DO i= 1, lons + champf (i,j,l) = champd (i,j,l) + ENDDO + ENDDO + ENDDO +c +c *** On tourne les longit. pour avoir - pi a + pi **** +c + DO i=1,lons + IF( xf(i).GT. pi ) THEN + GO TO 88 + ENDIF + ENDDO + +88 CONTINUE +c + ip180 = i + + DO i = 1,lons + IF (xf(i).GT. pi) THEN + xf(i) = xf(i) - depi + ENDIF + ENDDO + + DO i= ip180,lons + ind = i-ip180 +1 + xtemp(ind) = xf(i) + ENDDO + + DO i= ind +1,lons + xtemp(i) = xf(i-ind) + ENDDO + +c ..... on tourne les longitudes pour champf .... +c + DO l = 1,levs + DO j = 1,lats + DO i = ip180,lons + ind = i-ip180 +1 + champd (ind,j,l) = champf (i,j,l) + ENDDO + + DO i= ind +1,lons + champd (i,j,l) = champf (i-ind,j,l) + ENDDO + ENDDO + ENDDO + + ENDIF +c +c ***** fin de IF(invlon) **** + + IF ( invlat ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + + DO j = 1, lats + ytemp( lats-j+1 ) = yf(j) + DO i = 1, lons + champd (i,lats-j+1,l) = champf (i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + +c ***** fin de IF(invlat) **** +c +c + IF( interbar ) THEN + oldxd1 = xtemp(1) + DO i = 1, lons -1 + xtemp(i) = 0.5 * ( xtemp(i) + xtemp(i+1) ) + ENDDO + xtemp(lons) = 0.5 * ( xtemp(lons) + oldxd1 + depi ) + + DO j = 1, lats -1 + ytemp(j) = 0.5 * ( ytemp(j) + ytemp(j+1) ) + ENDDO + ENDIF +c + + invlev = .FALSE. + IF( ztemp(1).LT.ztemp(levs) ) invlev = .TRUE. + + presmax = MAX( ztemp(1), ztemp(levs) ) + IF( presmax.LT.1200. ) THEN + DO l = 1,levs + ztemp(l) = ztemp(l) * 100. + ENDDO + ENDIF + + IF( invlev ) THEN + + IF(.NOT.alloc) THEN + ALLOCATE(champf(lons,lats,levs)) + alloc = .TRUE. + ENDIF + + DO l = 1,levs + zf(l) = ztemp(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champf(i,j,l) = champd(i,j,l) + ENDDO + ENDDO + ENDDO + + DO l = 1,levs + ztemp(levs+1-l) = zf(l) + ENDDO + + DO l = 1,levs + DO j = 1, lats + DO i = 1,lons + champd(i,j,levs+1-l) = champf(i,j,l) + ENDDO + ENDDO + ENDDO + + + ENDIF + + IF(alloc) DEALLOCATE(champf) + + DO i = 1, lons + xf(i) = xtemp(i) + ENDDO + DO j = 1, lats + yf(j) = ytemp(j) + ENDDO + DO l = 1, levs + zf(l) = ztemp(l) + ENDDO + + DEALLOCATE(xtemp) + DEALLOCATE(ytemp) + DEALLOCATE(ztemp) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/conf_gcm.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/conf_gcm.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/conf_gcm.F (revision 1632) @@ -0,0 +1,868 @@ +! +! $Id: conf_gcm.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c +c + SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 ) +c +#ifdef CPP_IOIPSL + use IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + use ioipsl_getincom +#endif + use misc_mod + use mod_filtre_fft, ONLY : use_filtre_fft + use mod_filtre_fft_loc, ONLY : use_filtre_fft_loc=>use_filtre_fft + use mod_hallo, ONLY : use_mpi_alloc + use parallel, ONLY : omp_chunk + USE control_mod + IMPLICIT NONE +c----------------------------------------------------------------------- +c Auteurs : L. Fairhead , P. Le Van . +c +c Arguments : +c +c tapedef : +c etatinit : = TRUE , on ne compare pas les valeurs des para- +c -metres du zoom avec celles lues sur le fichier start . +c clesphy0 : sortie . +c + LOGICAL etatinit + INTEGER tapedef + + INTEGER longcles + PARAMETER( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Declarations : +c -------------- +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "serre.h" +#include "comdissnew.h" +!#include "clesphys.h" +#include "iniprint.h" +#include "temps.h" +#include "comconst.h" + +! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique +c +c +c local: +c ------ + + CHARACTER ch1*72,ch2*72,ch3*72,ch4*12 + REAL clonn,clatt,grossismxx,grossismyy + REAL dzoomxx,dzoomyy, tauxx,tauyy + LOGICAL fxyhypbb, ysinuss + INTEGER i + +c +c ------------------------------------------------------------------- +c +c ......... Version du 29/04/97 .......... +c +c Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot, +c tetatemp ajoutes pour la dissipation . +c +c Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** +c +c Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb. +c Sinon , choix de fxynew , a derivee sinusoidale .. +c +c ...... etatinit = . TRUE. si defrun est appele dans ETAT0_LMD ou +c LIMIT_LMD pour l'initialisation de start.dat (dic) et +c de limit.dat ( dic) ........... +c Sinon etatinit = . FALSE . +c +c Donc etatinit = .F. si on veut comparer les valeurs de grossismx , +c grossismy,clon,clat, fxyhypb lues sur le fichier start avec +c celles passees par run.def , au debut du gcm, apres l'appel a +c lectba . +c Ces parmetres definissant entre autres la grille et doivent etre +c pareils et coherents , sinon il y aura divergence du gcm . +c +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + adjust=.false. + call getin('adjust',adjust) + + itaumax=0 + call getin('itaumax',itaumax); + if (itaumax<=0) itaumax=HUGE(itaumax) + +!Config Key = lunout +!Config Desc = unite de fichier pour les impressions +!Config Def = 6 +!Config Help = unite de fichier pour les impressions +!Config (defaut sortie standard = 6) + lunout=6 + CALL getin('lunout', lunout) + IF (lunout /= 5 .and. lunout /= 6) THEN + OPEN(lunout,FILE='lmdz.out') + ENDIF + +!Config Key = prt_level +!Config Desc = niveau d'impressions de débogage +!Config Def = 0 +!Config Help = Niveau d'impression pour le débogage +!Config (0 = minimum d'impression) + prt_level = 0 + CALL getin('prt_level',prt_level) + +c----------------------------------------------------------------------- +c Parametres de controle du run: +c----------------------------------------------------------------------- +!Config Key = planet_type +!Config Desc = planet type ("earth", "mars", "venus", ...) +!Config Def = earth +!Config Help = this flag sets the type of atymosphere that is considered + planet_type="earth" + CALL getin('planet_type',planet_type) + +!Config Key = calend +!Config Desc = type de calendrier utilise +!Config Def = earth_360d +!Config Help = valeur possible: earth_360d, earth_365d, earth_366d +!Config + calend = 'earth_360d' + CALL getin('calend', calend) + +!Config Key = dayref +!Config Desc = Jour de l'etat initial +!Config Def = 1 +!Config Help = Jour de l'etat initial ( = 350 si 20 Decembre , +!Config par expl. ,comme ici ) ... A completer + dayref=1 + CALL getin('dayref', dayref) + +!Config Key = anneeref +!Config Desc = Annee de l'etat initial +!Config Def = 1998 +!Config Help = Annee de l'etat initial +!Config ( avec 4 chiffres ) ... A completer + anneeref = 1998 + CALL getin('anneeref',anneeref) + +!Config Key = raz_date +!Config Desc = Remise a zero de la date initiale +!Config Def = 0 (pas de remise a zero) +!Config Help = Remise a zero de la date initiale +!Config 0 pas de remise a zero, on garde la date du fichier restart +!Config 1 prise en compte de la date de gcm.def avec remise a zero +!Config des compteurs de pas de temps + raz_date = 0 + CALL getin('raz_date', raz_date) + +!Config Key = nday +!Config Desc = Nombre de jours d'integration +!Config Def = 10 +!Config Help = Nombre de jours d'integration +!Config ... On pourait aussi permettre des mois ou des annees ! + nday = 10 + CALL getin('nday',nday) + +!Config Key = day_step +!Config Desc = nombre de pas par jour +!Config Def = 240 +!Config Help = nombre de pas par jour (multiple de iperiod) ( +!Config ici pour dt = 1 min ) + day_step = 240 + CALL getin('day_step',day_step) + +!Config Key = iperiod +!Config Desc = periode pour le pas Matsuno +!Config Def = 5 +!Config Help = periode pour le pas Matsuno (en pas de temps) + iperiod = 5 + CALL getin('iperiod',iperiod) + +!Config Key = iapp_tracvl +!Config Desc = frequence du groupement des flux +!Config Def = iperiod +!Config Help = frequence du groupement des flux (en pas de temps) + iapp_tracvl = iperiod + CALL getin('iapp_tracvl',iapp_tracvl) + +!Config Key = iconser +!Config Desc = periode de sortie des variables de controle +!Config Def = 240 +!Config Help = periode de sortie des variables de controle +!Config (En pas de temps) + iconser = 240 + CALL getin('iconser', iconser) + +!Config Key = iecri +!Config Desc = periode d'ecriture du fichier histoire +!Config Def = 1 +!Config Help = periode d'ecriture du fichier histoire (en jour) + iecri = 1 + CALL getin('iecri',iecri) + + +!Config Key = periodav +!Config Desc = periode de stockage fichier histmoy +!Config Def = 1 +!Config Help = periode de stockage fichier histmoy (en jour) + periodav = 1. + CALL getin('periodav',periodav) + +!Config Key = output_grads_dyn +!Config Desc = output dynamics diagnostics in 'dyn.dat' file +!Config Def = n +!Config Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file + output_grads_dyn=.false. + CALL getin('output_grads_dyn',output_grads_dyn) + +!Config Key = idissip +!Config Desc = periode de la dissipation +!Config Def = 10 +!Config Help = periode de la dissipation +!Config (en pas) ... a completer ! + idissip = 10 + CALL getin('idissip',idissip) + +ccc .... P. Le Van , modif le 29/04/97 .pour la dissipation ... +ccc + +!Config Key = lstardis +!Config Desc = choix de l'operateur de dissipation +!Config Def = y +!Config Help = choix de l'operateur de dissipation +!Config 'y' si on veut star et 'n' si on veut non-start ! +!Config Moi y en a pas comprendre ! + lstardis = .TRUE. + CALL getin('lstardis',lstardis) + + +!Config Key = nitergdiv +!Config Desc = Nombre d'iteration de gradiv +!Config Def = 1 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config gradiv + nitergdiv = 1 + CALL getin('nitergdiv',nitergdiv) + +!Config Key = nitergrot +!Config Desc = nombre d'iterations de nxgradrot +!Config Def = 2 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config nxgradrot + nitergrot = 2 + CALL getin('nitergrot',nitergrot) + + +!Config Key = niterh +!Config Desc = nombre d'iterations de divgrad +!Config Def = 2 +!Config Help = nombre d'iterations de l'operateur de dissipation +!Config divgrad + niterh = 2 + CALL getin('niterh',niterh) + + +!Config Key = tetagdiv +!Config Desc = temps de dissipation pour div +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour u,v (gradiv) + tetagdiv = 7200. + CALL getin('tetagdiv',tetagdiv) + +!Config Key = tetagrot +!Config Desc = temps de dissipation pour grad +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour u,v (nxgradrot) + tetagrot = 7200. + CALL getin('tetagrot',tetagrot) + +!Config Key = tetatemp +!Config Desc = temps de dissipation pour h +!Config Def = 7200 +!Config Help = temps de dissipation des plus petites longeur +!Config d'ondes pour h (divgrad) + tetatemp = 7200. + CALL getin('tetatemp',tetatemp ) + +! Parametres controlant la variation sur la verticale des constantes de +! dissipation. +! Pour le moment actifs uniquement dans la version a 39 niveaux +! avec ok_strato=y + + dissip_factz=4. + dissip_deltaz=10. + dissip_zref=30. + CALL getin('dissip_factz',dissip_factz ) + CALL getin('dissip_deltaz',dissip_deltaz ) + CALL getin('dissip_zref',dissip_zref ) + + iflag_top_bound=1 + tau_top_bound=1.e-5 + CALL getin('iflag_top_bound',iflag_top_bound) + CALL getin('tau_top_bound',tau_top_bound) + +! +!Config Key = coefdis +!Config Desc = coefficient pour gamdissip +!Config Def = 0 +!Config Help = coefficient pour gamdissip + coefdis = 0. + CALL getin('coefdis',coefdis) + +!Config Key = purmats +!Config Desc = Schema d'integration +!Config Def = n +!Config Help = Choix du schema d'integration temporel. +!Config y = pure Matsuno sinon c'est du Matsuno-leapfrog + purmats = .FALSE. + CALL getin('purmats',purmats) + +!Config Key = ok_guide +!Config Desc = Guidage +!Config Def = n +!Config Help = Guidage + ok_guide = .FALSE. + CALL getin('ok_guide',ok_guide) + +c ............................................................... + +!Config Key = read_start +!Config Desc = Initialize model using a 'start.nc' file +!Config Def = y +!Config Help = y: intialize dynamical fields using a 'start.nc' file +! n: fields are initialized by 'iniacademic' routine + read_start= .true. + CALL getin('read_start',read_start) + +!Config Key = iflag_phys +!Config Desc = Avec ls physique +!Config Def = 1 +!Config Help = Permet de faire tourner le modele sans +!Config physique. + iflag_phys = 1 + CALL getin('iflag_phys',iflag_phys) + + +!Config Key = iphysiq +!Config Desc = Periode de la physique +!Config Def = 5 +!Config Help = Periode de la physique en pas de temps de la dynamique. + iphysiq = 5 + CALL getin('iphysiq', iphysiq) + +ccc .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ... +c + + +!Config Key = ip_ebil_dyn +!Config Desc = PRINT level for energy conserv. diag. +!Config Def = 0 +!Config Help = PRINT level for energy conservation diag. ; +! les options suivantes existent : +!Config 0 pas de print +!Config 1 pas de print +!Config 2 print, + ip_ebil_dyn = 0 + CALL getin('ip_ebil_dyn',ip_ebil_dyn) +! + + +ccc .... P. Le Van , ajout le 7/03/95 .pour le zoom ... +c ......... ( modif le 17/04/96 ) ......... +c + IF( etatinit ) GO TO 100 + +!Config Key = clon +!Config Desc = centre du zoom, longitude +!Config Def = 0 +!Config Help = longitude en degres du centre +!Config du zoom + clonn = 0. + CALL getin('clon',clonn) + +!Config Key = clat +!Config Desc = centre du zoom, latitude +!Config Def = 0 +!Config Help = latitude en degres du centre du zoom +!Config + clatt = 0. + CALL getin('clat',clatt) + +c +c + IF( ABS(clat - clatt).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de clat passee par run.def', + & ' est differente de celle lue sur le fichier start ' + STOP + ENDIF + +!Config Key = grossismx +!Config Desc = zoom en longitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la longitude + grossismxx = 1.0 + CALL getin('grossismx',grossismxx) + + + IF( ABS(grossismx - grossismxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de grossismx passee par ', + & 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + +!Config Key = grossismy +!Config Desc = zoom en latitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la latitude + grossismyy = 1.0 + CALL getin('grossismy',grossismyy) + + IF( ABS(grossismy - grossismyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de grossismy passee par ', + & 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + + IF( grossismx.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + + write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + +!Config Key = fxyhypb +!Config Desc = Fonction hyperbolique +!Config Def = y +!Config Help = Fonction f(y) hyperbolique si = .true. +!Config sinon sinusoidale + fxyhypbb = .TRUE. + CALL getin('fxyhypb',fxyhypbb) + + IF( .NOT.fxyhypb ) THEN + IF( fxyhypbb ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** fxyhypb lu sur le fichier start est ', + * 'F alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.fxyhypbb ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** fxyhypb lu sur le fichier start est ', + * 'T alors qu il est F sur run.def **** ' + STOP + ENDIF + ENDIF +c +!Config Key = dzoomx +!Config Desc = extension en longitude +!Config Def = 0 +!Config Help = extension en longitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomxx = 0.0 + CALL getin('dzoomx',dzoomxx) + + IF( fxyhypb ) THEN + IF( ABS(dzoomx - dzoomxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = dzoomy +!Config Desc = extension en latitude +!Config Def = 0 +!Config Help = extension en latitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomyy = 0.0 + CALL getin('dzoomy',dzoomyy) + + IF( fxyhypb ) THEN + IF( ABS(dzoomy - dzoomyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = taux +!Config Desc = raideur du zoom en X +!Config Def = 3 +!Config Help = raideur du zoom en X + tauxx = 3.0 + CALL getin('taux',tauxx) + + IF( fxyhypb ) THEN + IF( ABS(taux - tauxx).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de taux passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +!Config Key = tauyy +!Config Desc = raideur du zoom en Y +!Config Def = 3 +!Config Help = raideur du zoom en Y + tauyy = 3.0 + CALL getin('tauy',tauyy) + + IF( fxyhypb ) THEN + IF( ABS(tauy - tauyy).GE. 0.001 ) THEN + write(lunout,*)'conf_gcm: La valeur de tauy passee par ', + * 'run.def est differente de celle lue sur le fichier start ' + STOP + ENDIF + ENDIF + +cc + IF( .NOT.fxyhypb ) THEN + +!Config Key = ysinus +!Config IF = !fxyhypb +!Config Desc = Fonction en Sinus +!Config Def = y +!Config Help = Fonction f(y) avec y = Sin(latit.) si = .true. +!Config sinon y = latit. + ysinuss = .TRUE. + CALL getin('ysinus',ysinuss) + + IF( .NOT.ysinus ) THEN + IF( ysinuss ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** ysinus lu sur le fichier start est F', + * ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.ysinuss ) THEN + write(lunout,*)' ******** PBS DANS CONF_GCM ******** ' + write(lunout,*)' *** ysinus lu sur le fichier start est T', + * ' alors qu il est F sur run.def **** ' + STOP + ENDIF + ENDIF + ENDIF ! of IF( .NOT.fxyhypb ) +c +!Config Key = offline +!Config Desc = Nouvelle eau liquide +!Config Def = n +!Config Help = Permet de mettre en route la +!Config nouvelle parametrisation de l'eau liquide ! + offline = .FALSE. + CALL getin('offline',offline) + +!Config Key = config_inca +!Config Desc = Choix de configuration de INCA +!Config Def = none +!Config Help = Choix de configuration de INCA : +!Config 'none' = sans INCA +!Config 'chem' = INCA avec calcul de chemie +!Config 'aero' = INCA avec calcul des aerosols + config_inca = 'none' + CALL getin('config_inca',config_inca) + +!Config Key = ok_dynzon +!Config Desc = calcul et sortie des transports +!Config Def = n +!Config Help = Permet de mettre en route le calcul des transports +!Config + ok_dynzon = .FALSE. + CALL getin('ok_dynzon',ok_dynzon) + + + write(lunout,*)' #########################################' + write(lunout,*)' Configuration des parametres du gcm: ' + write(lunout,*)' planet_type = ', planet_type + write(lunout,*)' calend = ', calend + write(lunout,*)' dayref = ', dayref + write(lunout,*)' anneeref = ', anneeref + write(lunout,*)' nday = ', nday + write(lunout,*)' day_step = ', day_step + write(lunout,*)' iperiod = ', iperiod + write(lunout,*)' iconser = ', iconser + write(lunout,*)' iecri = ', iecri + write(lunout,*)' periodav = ', periodav + write(lunout,*)' output_grads_dyn = ', output_grads_dyn + write(lunout,*)' idissip = ', idissip + write(lunout,*)' lstardis = ', lstardis + write(lunout,*)' nitergdiv = ', nitergdiv + write(lunout,*)' nitergrot = ', nitergrot + write(lunout,*)' niterh = ', niterh + write(lunout,*)' tetagdiv = ', tetagdiv + write(lunout,*)' tetagrot = ', tetagrot + write(lunout,*)' tetatemp = ', tetatemp + write(lunout,*)' coefdis = ', coefdis + write(lunout,*)' purmats = ', purmats + write(lunout,*)' read_start = ', read_start + write(lunout,*)' iflag_phys = ', iflag_phys + write(lunout,*)' iphysiq = ', iphysiq + write(lunout,*)' clonn = ', clonn + write(lunout,*)' clatt = ', clatt + write(lunout,*)' grossismx = ', grossismx + write(lunout,*)' grossismy = ', grossismy + write(lunout,*)' fxyhypbb = ', fxyhypbb + write(lunout,*)' dzoomxx = ', dzoomxx + write(lunout,*)' dzoomy = ', dzoomyy + write(lunout,*)' tauxx = ', tauxx + write(lunout,*)' tauyy = ', tauyy + write(lunout,*)' offline = ', offline + write(lunout,*)' config_inca = ', config_inca + write(lunout,*)' ok_dynzon = ', ok_dynzon + + RETURN +c ............................................... +c +100 CONTINUE +!Config Key = clon +!Config Desc = centre du zoom, longitude +!Config Def = 0 +!Config Help = longitude en degres du centre +!Config du zoom + clon = 0. + CALL getin('clon',clon) + +!Config Key = clat +!Config Desc = centre du zoom, latitude +!Config Def = 0 +!Config Help = latitude en degres du centre du zoom +!Config + clat = 0. + CALL getin('clat',clat) + +!Config Key = grossismx +!Config Desc = zoom en longitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la longitude + grossismx = 1.0 + CALL getin('grossismx',grossismx) + +!Config Key = grossismy +!Config Desc = zoom en latitude +!Config Def = 1.0 +!Config Help = facteur de grossissement du zoom, +!Config selon la latitude + grossismy = 1.0 + CALL getin('grossismy',grossismy) + + IF( grossismx.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + write(lunout,*) + & 'conf_gcm: *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + + write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + +!Config Key = fxyhypb +!Config Desc = Fonction hyperbolique +!Config Def = y +!Config Help = Fonction f(y) hyperbolique si = .true. +!Config sinon sinusoidale + fxyhypb = .TRUE. + CALL getin('fxyhypb',fxyhypb) + +!Config Key = dzoomx +!Config Desc = extension en longitude +!Config Def = 0 +!Config Help = extension en longitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomx = 0.0 + CALL getin('dzoomx',dzoomx) + +!Config Key = dzoomy +!Config Desc = extension en latitude +!Config Def = 0 +!Config Help = extension en latitude de la zone du zoom +!Config ( fraction de la zone totale) + dzoomy = 0.0 + CALL getin('dzoomy',dzoomy) + +!Config Key = taux +!Config Desc = raideur du zoom en X +!Config Def = 3 +!Config Help = raideur du zoom en X + taux = 3.0 + CALL getin('taux',taux) + +!Config Key = tauy +!Config Desc = raideur du zoom en Y +!Config Def = 3 +!Config Help = raideur du zoom en Y + tauy = 3.0 + CALL getin('tauy',tauy) + +!Config Key = ysinus +!Config IF = !fxyhypb +!Config Desc = Fonction en Sinus +!Config Def = y +!Config Help = Fonction f(y) avec y = Sin(latit.) si = .true. +!Config sinon y = latit. + ysinus = .TRUE. + CALL getin('ysinus',ysinus) +c +!Config Key = offline +!Config Desc = Nouvelle eau liquide +!Config Def = n +!Config Help = Permet de mettre en route la +!Config nouvelle parametrisation de l'eau liquide ! + offline = .FALSE. + CALL getin('offline',offline) + +!Config Key = config_inca +!Config Desc = Choix de configuration de INCA +!Config Def = none +!Config Help = Choix de configuration de INCA : +!Config 'none' = sans INCA +!Config 'chem' = INCA avec calcul de chemie +!Config 'aero' = INCA avec calcul des aerosols + config_inca = 'none' + CALL getin('config_inca',config_inca) + +!Config Key = ok_dynzon +!Config Desc = calcul et sortie des transports +!Config Def = n +!Config Help = Permet de mettre en route le calcul des transports +!Config + ok_dynzon = .FALSE. + CALL getin('ok_dynzon',ok_dynzon) + +!Config Key = use_filtre_fft +!Config Desc = flag d'activation des FFT pour le filtre +!Config Def = false +!Config Help = permet d'activer l'utilisation des FFT pour effectuer +!Config le filtrage aux poles. + use_filtre_fft=.FALSE. + CALL getin('use_filtre_fft',use_filtre_fft) + use_filtre_fft_loc=use_filtre_fft + + IF (use_filtre_fft .AND. grossismx /= 1.0) THEN + write(lunout,*)'WARNING !!! ' + write(lunout,*)"Le zoom en longitude est incompatible", + & " avec l'utilisation du filtre FFT ", + & "---> filtre FFT désactivé " + use_filtre_fft=.FALSE. + ENDIF + + + +!Config Key = use_mpi_alloc +!Config Desc = Utilise un buffer MPI en m�moire globale +!Config Def = false +!Config Help = permet d'activer l'utilisation d'un buffer MPI +!Config en m�moire globale a l'aide de la fonction MPI_ALLOC. +!Config Cela peut am�liorer la bande passante des transferts MPI +!Config d'un facteur 2 + use_mpi_alloc=.FALSE. + CALL getin('use_mpi_alloc',use_mpi_alloc) + +!Config Key = omp_chunk +!Config Desc = taille des blocs openmp +!Config Def = 1 +!Config Help = defini la taille des packets d'it�ration openmp +!Config distribu�e � chaque t�che lors de l'entr�e dans une +!Config boucle parall�lis�e + + omp_chunk=1 + CALL getin('omp_chunk',omp_chunk) + +!Config key = ok_strato +!Config Desc = activation de la version strato +!Config Def = .FALSE. +!Config Help = active la version stratosphérique de LMDZ de F. Lott + + ok_strato=.FALSE. + CALL getin('ok_strato',ok_strato) + +!Config Key = ok_gradsfile +!Config Desc = activation des sorties grads du guidage +!Config Def = n +!Config Help = active les sorties grads du guidage + + ok_gradsfile = .FALSE. + CALL getin('ok_gradsfile',ok_gradsfile) + + write(lunout,*)' #########################################' + write(lunout,*)' Configuration des parametres du gcm: ' + write(lunout,*)' planet_type = ', planet_type + write(lunout,*)' calend = ', calend + write(lunout,*)' dayref = ', dayref + write(lunout,*)' anneeref = ', anneeref + write(lunout,*)' nday = ', nday + write(lunout,*)' day_step = ', day_step + write(lunout,*)' iperiod = ', iperiod + write(lunout,*)' iconser = ', iconser + write(lunout,*)' iecri = ', iecri + write(lunout,*)' periodav = ', periodav + write(lunout,*)' output_grads_dyn = ', output_grads_dyn + write(lunout,*)' idissip = ', idissip + write(lunout,*)' lstardis = ', lstardis + write(lunout,*)' nitergdiv = ', nitergdiv + write(lunout,*)' nitergrot = ', nitergrot + write(lunout,*)' niterh = ', niterh + write(lunout,*)' tetagdiv = ', tetagdiv + write(lunout,*)' tetagrot = ', tetagrot + write(lunout,*)' tetatemp = ', tetatemp + write(lunout,*)' coefdis = ', coefdis + write(lunout,*)' purmats = ', purmats + write(lunout,*)' read_start = ', read_start + write(lunout,*)' iflag_phys = ', iflag_phys + write(lunout,*)' iphysiq = ', iphysiq + write(lunout,*)' clon = ', clon + write(lunout,*)' clat = ', clat + write(lunout,*)' grossismx = ', grossismx + write(lunout,*)' grossismy = ', grossismy + write(lunout,*)' fxyhypb = ', fxyhypb + write(lunout,*)' dzoomx = ', dzoomx + write(lunout,*)' dzoomy = ', dzoomy + write(lunout,*)' taux = ', taux + write(lunout,*)' tauy = ', tauy + write(lunout,*)' offline = ', offline + write(lunout,*)' config_inca = ', config_inca + write(lunout,*)' ok_dynzon = ', ok_dynzon + write(lunout,*)' use_filtre_fft = ', use_filtre_fft + write(lunout,*)' use_mpi_alloc = ', use_mpi_alloc + write(lunout,*)' omp_chunk = ', omp_chunk + write(lunout,*)' ok_strato = ', ok_strato + write(lunout,*)' ok_gradsfile = ', ok_gradsfile +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/control.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/control.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/control.h (revision 1632) @@ -0,0 +1,29 @@ +! +! $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 'control.h' + + COMMON/control/nday,day_step, & + & iperiod,iapp_tracvl,iconser,iecri,idissip,iphysiq , & + & periodav,iecrimoy,dayref,anneeref, & + & raz_date,offline,ip_ebil_dyn,config_inca, & + & planet_type,output_grads_dyn,ok_dynzon + + INTEGER nday,day_step,iperiod,iapp_tracvl,iconser,iecri, & + & idissip,iphysiq,iecrimoy,dayref,anneeref, raz_date & + & ,ip_ebil_dyn + REAL periodav + 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 +!----------------------------------------------------------------------- Index: /LMDZ5/trunk/libf/dyn3dmem/control_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/control_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/control_mod.F90 (revision 1632) @@ -0,0 +1,26 @@ +! +! $Id$ +! + +MODULE control_mod + +! LF 01/2010 +! Remplacement du fichier et common control + + IMPLICIT NONE + + REAL :: periodav + INTEGER :: nday,day_step,iperiod,iapp_tracvl + INTEGER :: iconser,iecri,idissip,iphysiq,iecrimoy + INTEGER :: dayref,anneeref, raz_date, ip_ebil_dyn + LOGICAL :: offline, output_grads_dyn + CHARACTER (len=4) :: config_inca + CHARACTER (len=10) :: planet_type + + 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/dyn3dmem/convflu.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/convflu.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/convflu.F (revision 1632) @@ -0,0 +1,62 @@ +! +! $Header$ +! + SUBROUTINE convflu( xflu,yflu,nbniv,convfl ) +c +c P. Le Van +c +c +c ******************************************************************* +c ... calcule la (convergence horiz. * aire locale)du flux ayant pour +c composantes xflu et yflu ,variables extensives . ...... +c ******************************************************************* +c xflu , yflu et nbniv sont des arguments d'entree pour le s-pg .. +c convfl est un argument de sortie pour le s-pg . +c +c njxflu est le nombre de lignes de latitude de xflu, +c ( = jjm ou jjp1 ) +c nbniv est le nombre de niveaux vert. de xflu et de yflu . +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + REAL xflu,yflu,convfl,convpn,convps + INTEGER l,ij,nbniv + DIMENSION xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) , + * convfl( ip1jmp1,nbniv ) +c + REAL SSUM +c +c +#include "comgeom.h" +c + DO 5 l = 1,nbniv +c + DO 2 ij = iip2, ip1jm - 1 + convfl( ij + 1,l ) = xflu( ij,l ) - xflu( ij + 1,l ) + + * yflu(ij +1,l ) - yflu( ij -iim,l ) + 2 CONTINUE +c +c + +c .... correction pour convfl( 1,j,l) ...... +c .... convfl(1,j,l)= convfl(iip1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = iip2,ip1jm,iip1 + convfl( ij,l ) = convfl( ij + iim,l ) + 3 CONTINUE +c +c ...... calcul aux poles ....... +c + convpn = SSUM( iim, yflu( 1 ,l ), 1 ) + convps = - SSUM( iim, yflu( ip1jm-iim,l ), 1 ) + DO 4 ij = 1,iip1 + convfl( ij ,l ) = convpn * aire( ij ) / apoln + convfl( ij+ ip1jm,l ) = convps * aire( ij+ ip1jm) / apols + 4 CONTINUE +c + 5 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/convflu_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/convflu_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/convflu_loc.F (revision 1632) @@ -0,0 +1,84 @@ + SUBROUTINE convflu_loc( xflu,yflu,nbniv,convfl ) +c +c P. Le Van +c +c +c ******************************************************************* +c ... calcule la (convergence horiz. * aire locale)du flux ayant pour +c composantes xflu et yflu ,variables extensives . ...... +c ******************************************************************* +c xflu , yflu et nbniv sont des arguments d'entree pour le s-pg .. +c convfl est un argument de sortie pour le s-pg . +c +c njxflu est le nombre de lignes de latitude de xflu, +c ( = jjm ou jjp1 ) +c nbniv est le nombre de niveaux vert. de xflu et de yflu . +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + REAL xflu,yflu,convfl,convpn,convps + INTEGER l,ij,nbniv + DIMENSION xflu( ijb_u:ije_u,nbniv ),yflu( ijb_v:ije_v,nbniv ) , + * convfl( ijb_u:ije_u,nbniv ) +c + INTEGER ijb,ije + EXTERNAL SSUM + REAL SSUM +c +c +#include "comgeom.h" +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,nbniv +c + ijb=ij_begin + ije=ij_end+iip1 + + IF (pole_nord) ijb=ij_begin+iip1 + IF (pole_sud) ije=ij_end-iip1 + + DO 2 ij = ijb , ije - 1 + convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l) + + * yflu(ij +1,l ) - yflu( ij -iim,l ) + 2 CONTINUE +c +c + +c .... correction pour convfl( 1,j,l) ...... +c .... convfl(1,j,l)= convfl(iip1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = ijb,ije,iip1 + convfl( ij,l ) = convfl( ij + iim,l ) + 3 CONTINUE +c +c ...... calcul aux poles ....... +c + IF (pole_nord) THEN + + convpn = SSUM( iim, yflu( 1 ,l ), 1 ) + + DO ij = 1,iip1 + convfl(ij,l) = convpn * aire(ij) / apoln + ENDDO + + ENDIF + + IF (pole_sud) THEN + + convps = - SSUM( iim, yflu( ip1jm-iim,l ), 1 ) + + DO ij = 1,iip1 + convfl(ij+ip1jm,l) = convps * aire(ij+ ip1jm) / apols + ENDDO + + ENDIF + + 5 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/convflu_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/convflu_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/convflu_p.F (revision 1632) @@ -0,0 +1,84 @@ + SUBROUTINE convflu_p( xflu,yflu,nbniv,convfl ) +c +c P. Le Van +c +c +c ******************************************************************* +c ... calcule la (convergence horiz. * aire locale)du flux ayant pour +c composantes xflu et yflu ,variables extensives . ...... +c ******************************************************************* +c xflu , yflu et nbniv sont des arguments d'entree pour le s-pg .. +c convfl est un argument de sortie pour le s-pg . +c +c njxflu est le nombre de lignes de latitude de xflu, +c ( = jjm ou jjp1 ) +c nbniv est le nombre de niveaux vert. de xflu et de yflu . +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + REAL xflu,yflu,convfl,convpn,convps + INTEGER l,ij,nbniv + DIMENSION xflu( ip1jmp1,nbniv ),yflu( ip1jm,nbniv ) , + * convfl( ip1jmp1,nbniv ) +c + INTEGER ijb,ije + EXTERNAL SSUM + REAL SSUM +c +c +#include "comgeom.h" +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,nbniv +c + ijb=ij_begin + ije=ij_end+iip1 + + IF (pole_nord) ijb=ij_begin+iip1 + IF (pole_sud) ije=ij_end-iip1 + + DO 2 ij = ijb , ije - 1 + convfl(ij+1,l) = xflu(ij,l) - xflu(ij+ 1,l) + + * yflu(ij +1,l ) - yflu( ij -iim,l ) + 2 CONTINUE +c +c + +c .... correction pour convfl( 1,j,l) ...... +c .... convfl(1,j,l)= convfl(iip1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = ijb,ije,iip1 + convfl( ij,l ) = convfl( ij + iim,l ) + 3 CONTINUE +c +c ...... calcul aux poles ....... +c + IF (pole_nord) THEN + + convpn = SSUM( iim, yflu( 1 ,l ), 1 ) + + DO ij = 1,iip1 + convfl(ij,l) = convpn * aire(ij) / apoln + ENDDO + + ENDIF + + IF (pole_sud) THEN + + convps = - SSUM( iim, yflu( ip1jm-iim,l ), 1 ) + + DO ij = 1,iip1 + convfl(ij+ip1jm,l) = convps * aire(ij+ ip1jm) / apols + ENDDO + + ENDIF + + 5 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/convmas.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/convmas.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/convmas.F (revision 1632) @@ -0,0 +1,63 @@ +! +! $Header$ +! + SUBROUTINE convmas (pbaru, pbarv, convm ) +c + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ),convm( ip1jmp1,llm ) + INTEGER l,ij + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + CALL filtreg( convm, jjp1, llm, 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... + + DO l = llmm1, 1, -1 + DO ij = 1, ip1jmp1 + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/convmas1_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/convmas1_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/convmas1_loc.F (revision 1632) @@ -0,0 +1,64 @@ + SUBROUTINE convmas1_loc (pbaru, pbarv, convm ) +c + USE parallel + USE mod_filtreg_p + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm ) + REAL, target :: convm( ijb_u:ije_u,llm ) + INTEGER l,ij + + INTEGER ijb,ije,jjb,jje + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu_loc( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + + CALL filtreg_p( convm, jjb_u,jje_u,jjb, jje, jjp1, llm, + & 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/convmas2_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/convmas2_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/convmas2_loc.F (revision 1632) @@ -0,0 +1,56 @@ + SUBROUTINE convmas2_loc ( convm ) +c + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm ) + REAL :: convm( ijb_u:ije_u,llm ) + INTEGER l,ij + INTEGER ijb,ije,jjb,jje + +c$OMP MASTER +c integration de la convergence de masse de haut en bas ...... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO l = llmm1, 1, -1 + DO ij = ijb, ije + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c +c$OMP END MASTER + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/convmas_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/convmas_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/convmas_loc.F (revision 1632) @@ -0,0 +1,77 @@ + SUBROUTINE convmas_loc (pbaru, pbarv, convm ) +c + USE parallel + USE mod_filtreg_p + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm ) + REAL, target :: convm( ijb_u:ije_u,llm ) + INTEGER l,ij + + INTEGER ijb,ije,jjb,jje + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu_loc( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + + CALL filtreg_p(convm, jjb_u, jje_u,jjb, jje, jjp1, llm, + & 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... +!$OMP BARRIER +!$OMP MASTER + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO l = llmm1, 1, -1 + DO ij = ijb, ije + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c +!$OMP END MASTER +!$OMP BARRIER + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/convmas_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/convmas_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/convmas_p.F (revision 1632) @@ -0,0 +1,71 @@ + SUBROUTINE convmas_p (pbaru, pbarv, convm ) +c + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************** +c .... calcul de la convergence du flux de masse aux niveaux p ... +c ******************************************************************** +c +c +c pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c ..... convm est un argument de sortie pour le s-pg .... +c +c le calcul se fait de haut en bas, +c la convergence de masse au niveau p(llm+1) est egale a 0. et +c n'est pas stockee dans le tableau convm . +c +c +c======================================================================= +c +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "logic.h" + + REAL pbaru( ip1jmp1,llm ),pbarv( ip1jm,llm ) + REAL, target :: convm( ip1jmp1,llm ) + INTEGER l,ij + + INTEGER ijb,ije,jjb,jje + + +c----------------------------------------------------------------------- +c .... calcul de - (d(pbaru)/dx + d(pbarv)/dy ) ...... + + CALL convflu_p( pbaru, pbarv, llm, convm ) + +c----------------------------------------------------------------------- +c filtrage: +c --------- + + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + + CALL filtreg_p( convm, jjb, jje, jjp1, llm, 2, 2, .true., 1 ) + +c integration de la convergence de masse de haut en bas ...... + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ij_end + + DO l = llmm1, 1, -1 + DO ij = ijb, ije + convm(ij,l) = convm(ij,l) + convm(ij,l+1) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/coordij.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/coordij.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/coordij.F (revision 1632) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE coordij(lon,lat,ilon,jlat) + +c======================================================================= +c +c calcul des coordonnees i et j de la maille scalaire dans +c laquelle se trouve le point (lon,lat) en radian +c +c======================================================================= + + IMPLICIT NONE + REAL lon,lat + INTEGER ilon,jlat + INTEGER i,j + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "serre.h" + + real zlon,zlat + + zlon=lon*pi/180. + zlat=lat*pi/180. + + DO i=1,iim+1 + IF (rlonu(i).GT.zlon) THEN + ilon=i + GOTO 10 + ENDIF + ENDDO +10 CONTINUE + + j=0 + DO j=1,jjm + IF(rlatv(j).LT.zlat) THEN + jlat=j + GOTO 20 + ENDIF + ENDDO +20 CONTINUE + IF(j.EQ.0) j=jjm+1 + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/covcont.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/covcont.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/covcont.F (revision 1632) @@ -0,0 +1,43 @@ +! +! $Header$ +! + SUBROUTINE covcont (klevel,ucov, vcov, ucont, vcont ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. contravariantes a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL ucont( ip1jmp1,klevel ), vcont( ip1jm,klevel ) + INTEGER l,ij + + + DO 10 l = 1,klevel + + DO 2 ij = iip2, ip1jm + ucont( ij,l ) = ucov( ij,l ) * unscu2( ij ) + 2 CONTINUE + + DO 4 ij = 1,ip1jm + vcont( ij,l ) = vcov( ij,l ) * unscv2( ij ) + 4 CONTINUE + + 10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/covcont_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/covcont_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/covcont_loc.F (revision 1632) @@ -0,0 +1,59 @@ + SUBROUTINE covcont_loc (klevel,ucov, vcov, ucont, vcont ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. contravariantes a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ijb_u:ije_u,klevel ), vcov( ijb_v:ije_v,klevel ) + REAL ucont( ijb_u:ije_u,klevel ), vcont( ijb_v:ije_v,klevel ) + INTEGER l,ij + INTEGER ijbu,ijbv,ijeu,ijev + + + ijbu=ij_begin-iip1 + ijbv=ij_begin-iip1 + ijeu=ij_end+iip1 + ijev=ij_end+iip1 + + if (pole_nord) then + ijbu=ij_begin+iip1 + ijbv=ij_begin + endif + + if (pole_sud) then + ijeu=ij_end-iip1 + ijev=ij_end-iip1 + endif + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel + + DO 2 ij = ijb_u,ije_u + ucont( ij,l ) = ucov( ij,l ) * unscu2( ij ) + 2 CONTINUE + + DO 4 ij = ijb_v,ije_v + vcont( ij,l ) = vcov( ij,l ) * unscv2( ij ) + 4 CONTINUE + + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/covnat_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/covnat_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/covnat_loc.F (revision 1632) @@ -0,0 +1,84 @@ +! +! $Header$ +! + SUBROUTINE covnat_loc(klevel,ucov, vcov, unat, vnat ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: F Hourdin Phu LeVan +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. naturelles a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ijb_u:ije_u,klevel ), vcov( ijb_v:ije_v,klevel ) + REAL unat( ijb_u:ije_u,klevel ), vnat( ijb_v:ije_v,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije + + + ijb=ij_begin + ije=ij_end + + if (pole_nord) then + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + DO ij = 1, iip1 + unat (ij,l) =0. + END DO + ENDDO +!$OMP ENDDO NOWAIT + endif + + if (pole_sud) then +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + DO ij = ip1jm+1, ip1jmp1 + unat (ij,l) =0. + END DO + ENDDO +!$OMP ENDDO NOWAIT + endif + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + DO ij = ijb, ije + unat( ij,l ) = ucov( ij,l ) / cu(ij) + ENDDO + END DO +!$OMP ENDDO NOWAIT + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + DO ij = ijb,ije + vnat( ij,l ) = vcov( ij,l ) / cv(ij) + ENDDO + ENDDO +!$OMP ENDDO NOWAIT + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/covnat_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/covnat_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/covnat_p.F (revision 1632) @@ -0,0 +1,76 @@ +! +! $Header$ +! + SUBROUTINE covnat_p(klevel,ucov, vcov, unat, vnat ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: F Hourdin Phu LeVan +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c calcul des compos. naturelles a partir des comp.covariantes +c ******************************************************************** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL unat( ip1jmp1,klevel ), vnat( ip1jm,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije + + + ijb=ij_begin + ije=ij_end + + if (pole_nord) then + DO l = 1,klevel + DO ij = 1, iip1 + unat (ij,l) =0. + END DO + ENDDO + endif + + if (pole_sud) then + DO l = 1,klevel + DO ij = ip1jm+1, ip1jmp1 + unat (ij,l) =0. + END DO + ENDDO + endif + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO l = 1,klevel + DO ij = ijb, ije + unat( ij,l ) = ucov( ij,l ) / cu(ij) + ENDDO + END DO + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO l = 1,klevel + DO ij = ijb,ije + vnat( ij,l ) = vcov( ij,l ) / cv(ij) + ENDDO + + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/cray.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/cray.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/cray.F (revision 1632) @@ -0,0 +1,54 @@ +! +! $Header$ +! +#ifdef CRAY + SUBROUTINE riencray + END +#else + subroutine scopy(n,sx,incx,sy,incy) +c + IMPLICIT NONE +c + integer n,incx,incy,ix,iy,i + real sx((n-1)*incx+1),sy((n-1)*incy+1) +c + if (incx.eq.1.and.incy.eq.1) then + do 10 i=1,n + sy(i)=sx(i) +10 continue + else + iy=1 + ix=1 + do 11 i=1,n + sy(iy)=sx(ix) + ix=ix+incx + iy=iy+incy +11 continue + endif +c + return + end + + function ssum(n,sx,incx) +c + IMPLICIT NONE +c + integer n,incx,i,ix + real ssum,sx((n-1)*incx+1) +c + ssum=0. + if (incx.eq.1) then + do 10 i=1,n + ssum=ssum+sx(i) +10 continue + else + ix=1 + do 11 i=1,n + ssum=ssum+sx(ix) + ix=ix+incx +11 continue + endif +c + return + end +#endif Index: /LMDZ5/trunk/libf/dyn3dmem/create_etat0_limit.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/create_etat0_limit.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/create_etat0_limit.F (revision 1632) @@ -0,0 +1,86 @@ +! +! $Id: create_etat0_limit.F 1299 2010-01-20 14:27:21Z fairhead $ +! + PROGRAM create_etat0_limit +#ifdef CPP_EARTH +! This prog. is designed to work for Earth + USE dimphy + USE comgeomphy + USE mod_phys_lmdz_para + USE mod_const_mpi + USE infotrac + USE control_mod +#ifdef CPP_IOIPSL + use ioipsl, only: ioconf_calendar +#endif + IMPLICIT NONE +c +c +c Programme d'appel a etat0, creation des etats initiaux et limit_netcdf +c +c +c interbar = .T . si appel a interpol. barycentrique inter_barxy +c +c extrap = .T . si on fait une extrapolation de donnees , comme pour +c les SST lorsque le fichier ne contient pas uniquement des points +c oceaniques . +c +c oldice = .T. si l'on veut garder les anciennes glaces , obtenues +c par grille_m ( grid_atob ) . +c +c on cree le masque dans etat0 que l'on passe ensuite dans limit pour +c garder les coherences + + LOGICAL interbar, extrap , oldice + PARAMETER ( interbar = .true. , extrap = .FALSE. , oldice=.false.) +#include "dimensions.h" +#include "paramet.h" +#include "indicesol.h" + REAL :: masque(iip1,jjp1) +! REAL :: pctsrf(iim*(jjm-1)+2, nbsrf) + + IF (config_inca /= 'none') THEN +#ifdef INCA + call init_const_lmdz( + $ nbtr,anneeref,dayref, + $ iphysiq, day_step,nday) +#endif + print *, 'nbtr =' , nbtr + END IF + + CALL init_mpi + + + CALL Init_Phys_lmdz(iim,jjp1,llm,1,(/(jjm-1)*iim+2/)) + PRINT *,'---> klon=',klon + + IF (mpi_size>1 .OR. omp_size>1) THEN + CALL abort_gcm('create_etat0_limit','In parallel mode, + & create_etat0_limit must be called only + & for 1 process and 1 task') + ENDIF + call InitComgeomphy + +#ifdef CPP_IOIPSL + call ioconf_calendar('360d') +#endif + + WRITE(6,*) ' ********************* ' + WRITE(6,*) ' interbar = ',interbar + CALL etat0_netcdf ( interbar, masque ) +c + WRITE(6,1) + WRITE(6,*) ' ********************* ' + WRITE(6,*) ' *** Limit_netcdf *** ' + WRITE(6,*) ' ********************* ' + WRITE(6,1) + +c + CALL limit_netcdf ( interbar, extrap , oldice, masque) + +1 FORMAT(//) + +#endif +! of #ifdef CPP_EARTH + STOP + END Index: /LMDZ5/trunk/libf/dyn3dmem/defrun.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/defrun.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/defrun.F (revision 1632) @@ -0,0 +1,497 @@ +! +! $Id: defrun.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c +c + SUBROUTINE defrun( tapedef, etatinit, clesphy0 ) +c + USE control_mod + IMPLICIT NONE +c----------------------------------------------------------------------- +c Auteurs : L. Fairhead , P. Le Van . +c +c Arguments : +c +c tapedef : +c etatinit : = TRUE , on ne compare pas les valeurs des para- +c -metres du zoom avec celles lues sur le fichier start . +c clesphy0 : sortie . +c + LOGICAL etatinit + INTEGER tapedef + + INTEGER longcles + PARAMETER( longcles = 20 ) + REAL clesphy0( longcles ) +c +c Declarations : +c -------------- +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "serre.h" +#include "comdissnew.h" +#include "clesph0.h" +c +c +c local: +c ------ + + CHARACTER ch1*72,ch2*72,ch3*72,ch4*12 + INTEGER tapeout + REAL clonn,clatt,grossismxx,grossismyy + REAL dzoomxx,dzoomyy,tauxx,tauyy + LOGICAL fxyhypbb, ysinuss + INTEGER i + +c +c ------------------------------------------------------------------- +c +c ......... Version du 29/04/97 .......... +c +c Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot, +c tetatemp ajoutes pour la dissipation . +c +c Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** +c +c Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb. +c Sinon , choix de fxynew , a derivee sinusoidale .. +c +c ...... etatinit = . TRUE. si defrun est appele dans ETAT0_LMD ou +c LIMIT_LMD pour l'initialisation de start.dat (dic) et +c de limit.dat ( dic) ........... +c Sinon etatinit = . FALSE . +c +c Donc etatinit = .F. si on veut comparer les valeurs de grossismx , +c grossismy,clon,clat, fxyhypb lues sur le fichier start avec +c celles passees par run.def , au debut du gcm, apres l'appel a +c lectba . +c Ces parmetres definissant entre autres la grille et doivent etre +c pareils et coherents , sinon il y aura divergence du gcm . +c +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + + tapeout = 6 + +c----------------------------------------------------------------------- +c Parametres de controle du run: +c----------------------------------------------------------------------- + + OPEN( tapedef,file ='gcm.def',status='old',form='formatted') + + + READ (tapedef,9000) ch1,ch2,ch3 + WRITE(tapeout,9000) ch1,ch2,ch3 + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dayref + WRITE(tapeout,9001) ch1,'dayref' + WRITE(tapeout,*) dayref + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) anneeref + WRITE(tapeout,9001) ch1,'anneeref' + WRITE(tapeout,*) anneeref + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nday + WRITE(tapeout,9001) ch1,'nday' + WRITE(tapeout,*) nday + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) day_step + WRITE(tapeout,9001) ch1,'day_step' + WRITE(tapeout,*) day_step + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iperiod + WRITE(tapeout,9001) ch1,'iperiod' + WRITE(tapeout,*) iperiod + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iapp_tracvl + WRITE(tapeout,9001) ch1,'iapp_tracvl' + WRITE(tapeout,*) iapp_tracvl + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iconser + WRITE(tapeout,9001) ch1,'iconser' + WRITE(tapeout,*) iconser + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iecri + WRITE(tapeout,9001) ch1,'iecri' + WRITE(tapeout,*) iecri + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) periodav + WRITE(tapeout,9001) ch1,'periodav' + WRITE(tapeout,*) periodav + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) idissip + WRITE(tapeout,9001) ch1,'idissip' + WRITE(tapeout,*) idissip + +ccc .... P. Le Van , modif le 29/04/97 .pour la dissipation ... +ccc + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) lstardis + WRITE(tapeout,9001) ch1,'lstardis' + WRITE(tapeout,*) lstardis + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nitergdiv + WRITE(tapeout,9001) ch1,'nitergdiv' + WRITE(tapeout,*) nitergdiv + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nitergrot + WRITE(tapeout,9001) ch1,'nitergrot' + WRITE(tapeout,*) nitergrot + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) niterh + WRITE(tapeout,9001) ch1,'niterh' + WRITE(tapeout,*) niterh + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetagdiv + WRITE(tapeout,9001) ch1,'tetagdiv' + WRITE(tapeout,*) tetagdiv + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetagrot + WRITE(tapeout,9001) ch1,'tetagrot' + WRITE(tapeout,*) tetagrot + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tetatemp + WRITE(tapeout,9001) ch1,'tetatemp' + WRITE(tapeout,*) tetatemp + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) coefdis + WRITE(tapeout,9001) ch1,'coefdis' + WRITE(tapeout,*) coefdis +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) purmats + WRITE(tapeout,9001) ch1,'purmats' + WRITE(tapeout,*) purmats + +c ............................................................... + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iflag_phys + WRITE(tapeout,9001) ch1,'iflag_phys' + WRITE(tapeout,*) iflag_phys + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iphysiq + WRITE(tapeout,9001) ch1,'iphysiq' + WRITE(tapeout,*) iphysiq + + +ccc .... P.Le Van, ajout le 03/01/96 pour l'ecriture phys ... +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) cycle_diurne + WRITE(tapeout,9001) ch1,'cycle_diurne' + WRITE(tapeout,*) cycle_diurne + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) soil_model + WRITE(tapeout,9001) ch1,'soil_model' + WRITE(tapeout,*) soil_model + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) new_oliq + WRITE(tapeout,9001) ch1,'new_oliq' + WRITE(tapeout,*) new_oliq + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_orodr + WRITE(tapeout,9001) ch1,'ok_orodr' + WRITE(tapeout,*) ok_orodr + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_orolf + WRITE(tapeout,9001) ch1,'ok_orolf' + WRITE(tapeout,*) ok_orolf + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ok_limitvrai + WRITE(tapeout,9001) ch1,'ok_limitvrai' + WRITE(tapeout,*) ok_limitvrai + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) nbapp_rad + WRITE(tapeout,9001) ch1,'nbapp_rad' + WRITE(tapeout,*) nbapp_rad + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) iflag_con + WRITE(tapeout,9001) ch1,'iflag_con' + WRITE(tapeout,*) iflag_con + + DO i = 1, longcles + clesphy0(i) = 0. + ENDDO + clesphy0(1) = REAL( iflag_con ) + clesphy0(2) = REAL( nbapp_rad ) + + IF( cycle_diurne ) clesphy0(3) = 1. + IF( soil_model ) clesphy0(4) = 1. + IF( new_oliq ) clesphy0(5) = 1. + IF( ok_orodr ) clesphy0(6) = 1. + IF( ok_orolf ) clesphy0(7) = 1. + IF( ok_limitvrai ) clesphy0(8) = 1. + + +ccc .... P. Le Van , ajout le 7/03/95 .pour le zoom ... +c ......... ( modif le 17/04/96 ) ......... +c + IF( etatinit ) GO TO 100 + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clonn + WRITE(tapeout,9001) ch1,'clon' + WRITE(tapeout,*) clonn + IF( ABS(clon - clonn).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de clon passee par run.def est diffe + *rente de celle lue sur le fichier start ' + STOP + ENDIF +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clatt + WRITE(tapeout,9001) ch1,'clat' + WRITE(tapeout,*) clatt + + IF( ABS(clat - clatt).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de clat passee par run.def est diffe + *rente de celle lue sur le fichier start ' + STOP + ENDIF + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismxx + WRITE(tapeout,9001) ch1,'grossismx' + WRITE(tapeout,*) grossismxx + + IF( ABS(grossismx - grossismxx).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de grossismx passee par run.def est + , differente de celle lue sur le fichier start ' + STOP + ENDIF + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismyy + WRITE(tapeout,9001) ch1,'grossismy' + WRITE(tapeout,*) grossismyy + + IF( ABS(grossismy - grossismyy).GE. 0.001 ) THEN + WRITE(tapeout,*) ' La valeur de grossismy passee par run.def est + , differente de celle lue sur le fichier start ' + STOP + ENDIF + + IF( grossismx.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + + IF( grossismy.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + +c +c alphax et alphay sont les anciennes formulat. des grossissements +c +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) fxyhypbb + WRITE(tapeout,9001) ch1,'fxyhypbb' + WRITE(tapeout,*) fxyhypbb + + IF( .NOT.fxyhypb ) THEN + IF( fxyhypbb ) THEN + WRITE(tapeout,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est F' + *, ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.fxyhypbb ) THEN + WRITE(tapeout,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)' *** fxyhypb lu sur le fichier start est t' + *, ' alors qu il est F sur run.def ***' + STOP + ENDIF + ENDIF +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomxx + WRITE(tapeout,9001) ch1,'dzoomx' + WRITE(tapeout,*) dzoomxx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomyy + WRITE(tapeout,9001) ch1,'dzoomy' + WRITE(tapeout,*) dzoomyy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauxx + WRITE(tapeout,9001) ch1,'taux' + WRITE(tapeout,*) tauxx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauyy + WRITE(tapeout,9001) ch1,'tauy' + WRITE(tapeout,*) tauyy + + IF( fxyhypb ) THEN + + IF( ABS(dzoomx - dzoomxx).GE. 0.001 ) THEN + WRITE(tapeout,*)' La valeur de dzoomx passee par run.def est dif + *ferente de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(dzoomy - dzoomyy).GE. 0.001 ) THEN + WRITE(tapeout,*)' La valeur de dzoomy passee par run.def est dif + *ferente de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(taux - tauxx).GE. 0.001 ) THEN + WRITE(6,*)' La valeur de taux passee par run.def est differente + * de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + IF( ABS(tauy - tauyy).GE. 0.001 ) THEN + WRITE(6,*)' La valeur de tauy passee par run.def est differente + * de celle lue sur le fichier start ' + CALL ABORT + ENDIF + + ENDIF + +cc + IF( .NOT.fxyhypb ) THEN + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ysinuss + WRITE(tapeout,9001) ch1,'ysinus' + WRITE(tapeout,*) ysinuss + + + IF( .NOT.ysinus ) THEN + IF( ysinuss ) THEN + WRITE(6,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)'** ysinus lu sur le fichier start est F', + * ' alors qu il est T sur run.def ***' + STOP + ENDIF + ELSE + IF( .NOT.ysinuss ) THEN + WRITE(6,*) ' ******** PBS DANS DEFRUN ******** ' + WRITE(tapeout,*)'** ysinus lu sur le fichier start est T', + * ' alors qu il est F sur run.def ***' + STOP + ENDIF + ENDIF + ENDIF +c + WRITE(6,*) ' alphax alphay defrun ',alphax,alphay + + CLOSE(tapedef) + + RETURN +c ............................................... +c +100 CONTINUE +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clon + WRITE(tapeout,9001) ch1,'clon' + WRITE(tapeout,*) clon +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) clat + WRITE(tapeout,9001) ch1,'clat' + WRITE(tapeout,*) clat + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismx + WRITE(tapeout,9001) ch1,'grossismx' + WRITE(tapeout,*) grossismx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) grossismy + WRITE(tapeout,9001) ch1,'grossismy' + WRITE(tapeout,*) grossismy + + IF( grossismx.LT.1. ) THEN + WRITE(tapeout,*) '*** ATTENTION !! grossismx < 1 . *** ' + STOP + ELSE + alphax = 1. - 1./ grossismx + ENDIF + + IF( grossismy.LT.1. ) THEN + WRITE(tapeout,*) ' *** ATTENTION !! grossismy < 1 . *** ' + STOP + ELSE + alphay = 1. - 1./ grossismy + ENDIF + +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) fxyhypb + WRITE(tapeout,9001) ch1,'fxyhypb' + WRITE(tapeout,*) fxyhypb + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomx + WRITE(tapeout,9001) ch1,'dzoomx' + WRITE(tapeout,*) dzoomx + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) dzoomy + WRITE(tapeout,9001) ch1,'dzoomy' + WRITE(tapeout,*) dzoomy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) taux + WRITE(tapeout,9001) ch1,'taux' + WRITE(tapeout,*) taux +c + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) tauy + WRITE(tapeout,9001) ch1,'tauy' + WRITE(tapeout,*) tauy + + READ (tapedef,9001) ch1,ch4 + READ (tapedef,*) ysinus + WRITE(tapeout,9001) ch1,'ysinus' + WRITE(tapeout,*) ysinus + + WRITE(tapeout,*) ' alphax alphay defrun ',alphax,alphay +c +9000 FORMAT(3(/,a72)) +9001 FORMAT(/,a72,/,a12) +cc + CLOSE(tapedef) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/description.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/description.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/description.h (revision 1632) @@ -0,0 +1,5 @@ +! +! $Header$ +! + character (len=120) :: descript + common /titre/descript Index: /LMDZ5/trunk/libf/dyn3dmem/diagedyn.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/diagedyn.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/diagedyn.F (revision 1632) @@ -0,0 +1,321 @@ +! +! $Id: diagedyn.F 1279 2009-12-10 09:02:56Z fairhead $ +! + +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/dyn3dmem/dimensions_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dimensions_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dimensions_mod.F90 (revision 1632) @@ -0,0 +1,4 @@ +MODULE dimensions + INCLUDE 'dimensions.h' + INCLUDE 'paramet.h' +END MODULE dimensions Index: /LMDZ5/trunk/libf/dyn3dmem/dissip_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dissip_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dissip_loc.F (revision 1632) @@ -0,0 +1,228 @@ + SUBROUTINE dissip_loc( vcov,ucov,teta,p, dv,du,dh ) +c + USE parallel + USE write_field_loc + USE dissip_mod + IMPLICIT NONE + + +c .. Avec nouveaux operateurs star : gradiv2 , divgrad2, nxgraro2 ... +c ( 10/01/98 ) + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c Dissipation horizontale +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comdissnew.h" +#include "comdissipn.h" + +c Arguments: +c ---------- + + REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) + REAL teta(ijb_u:ije_u,llm) + REAL p( ijb_u:ije_u,llmp1 ) + REAL dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm),dh(ijb_u:ije_u,llm) + +c Local: +c ------ + + REAL gdx(ijb_u:ije_u,llm),gdy(ijb_v:ije_v,llm) + REAL grx(ijb_u:ije_u,llm),gry(ijb_v:ije_v,llm) + REAL te1dt(llm),te2dt(llm),te3dt(llm) + REAL deltapres(ijb_u:ije_u,llm) + + INTEGER l,ij + + REAL SSUM + integer :: ijb,ije + + LOGICAl,SAVE :: first=.TRUE. +!$OMP THREADPRIVATE(first) + + PRINT *,"----> calldissip" + IF (first) THEN + CALL dissip_allocate + first=.FALSE. + ENDIF +c----------------------------------------------------------------------- +c initialisations: +c ---------------- + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + te1dt(l) = tetaudiv(l) * dtdiss + te2dt(l) = tetaurot(l) * dtdiss + te3dt(l) = tetah(l) * dtdiss + ENDDO +c$OMP END DO NOWAIT +c CALL initial0( ijp1llm, du ) +c CALL initial0( ijmllm , dv ) +c CALL initial0( ijp1llm, dh ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + du(ijb:ije,l)=0 + dh(ijb:ije,l)=0 + ENDDO +c$OMP END DO NOWAIT + + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + dv(ijb:ije,l)=0 + ENDDO +c$OMP END DO NOWAIT + +c----------------------------------------------------------------------- +c Calcul de la dissipation: +c ------------------------- + +c Calcul de la partie grad ( div ) : +c ------------------------------------- + + + + IF(lstardis) THEN +c IF (.FALSE.) THEN + CALL gradiv2_loc( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ELSE +! CALL gradiv_p ( llm,ucov,vcov,nitergdiv,gdx,gdy ) + ENDIF + +#ifdef DEBUG_IO + call WriteField_u('gdx',gdx) + call WriteField_v('gdy',gdy) +#endif + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + if (pole_nord) then + DO ij = 1, iip1 + gdx( ij ,l) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iip1 + gdx(ij+ip1jm,l) = 0. + ENDDO + endif + + if (pole_nord) ijb=ij_begin+iip1 + DO ij = ijb,ije + du(ij,l) = du(ij,l) - te1dt(l) *gdx(ij,l) + ENDDO + + if (pole_nord) ijb=ij_begin + DO ij = ijb,ije + dv(ij,l) = dv(ij,l) - te1dt(l) *gdy(ij,l) + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c calcul de la partie n X grad ( rot ): +c --------------------------------------- + + IF(lstardis) THEN +c IF (.FALSE.) THEN + CALL nxgraro2_loc( llm,ucov, vcov, nitergrot,grx,gry ) + ELSE +! CALL nxgrarot_p( llm,ucov, vcov, nitergrot,grx,gry ) + ENDIF + +#ifdef DEBUG_IO + call WriteField_u('grx',grx) + call WriteField_v('gry',gry) +#endif + + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + + if (pole_nord) then + DO ij = 1, iip1 + grx(ij,l) = 0. + ENDDO + endif + + if (pole_nord) ijb=ij_begin+iip1 + DO ij = ijb,ije + du(ij,l) = du(ij,l) - te2dt(l) * grx(ij,l) + ENDDO + + if (pole_nord) ijb=ij_begin + DO ij = ijb, ije + dv(ij,l) = dv(ij,l) - te2dt(l) * gry(ij,l) + ENDDO + + ENDDO +c$OMP END DO NOWAIT + +c calcul de la partie div ( grad ): +c ----------------------------------- + + + IF(lstardis) THEN +c IF (.FALSE.) THEN + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + deltapres(ij,l) = AMAX1( 0., p(ij,l) - p(ij,l+1) ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + CALL divgrad2_loc( llm,teta, deltapres ,niterh, gdx ) + ELSE +! CALL divgrad_p ( llm,teta, niterh, gdx ) + ENDIF + +#ifdef DEBUG_IO + call WriteField_u('gdx',gdx) +#endif + + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + DO ij = ijb,ije + dh( ij,l ) = dh( ij,l ) - te3dt(l) * gdx( ij,l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/dissip_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dissip_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dissip_mod.F90 (revision 1632) @@ -0,0 +1,40 @@ +MODULE dissip_mod + + + +CONTAINS + + SUBROUTINE dissip_allocate + USE bands + USE allocate_field + USE parallel + USE dimensions + USE gradiv2_mod, ONLY : gradiv2_allocate + USE nxgraro2_mod, ONLY : nxgraro2_allocate + USE divgrad2_mod, ONLY : divgrad2_allocate + IMPLICIT NONE + + CALL gradiv2_allocate + CALL nxgraro2_allocate + CALL divgrad2_allocate + + + END SUBROUTINE dissip_allocate + + SUBROUTINE dissip_switch_dissip(dist) + USE allocate_field + USE bands + USE parallel + USE gradiv2_mod,ONLY : gradiv2_switch_dissip + USE nxgraro2_mod,ONLY : nxgraro2_switch_dissip + USE divgrad2_mod,ONLY : divgrad2_switch_dissip + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL gradiv2_switch_dissip(dist) + CALL nxgraro2_switch_dissip(dist) + CALL divgrad2_switch_dissip(dist) + + END SUBROUTINE dissip_switch_dissip + +END MODULE dissip_mod Index: /LMDZ5/trunk/libf/dyn3dmem/disvert.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/disvert.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/disvert.F (revision 1632) @@ -0,0 +1,194 @@ +! +! $Id: disvert.F 1299 2010-01-20 14:27:21Z fairhead $ +! + SUBROUTINE disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig) + +c Auteur : P. Le Van . +c + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +#include "logic.h" +c +c======================================================================= +c +c +c s = sigma ** kappa : coordonnee verticale +c dsig(l) : epaisseur de la couche l ds la coord. s +c sig(l) : sigma a l'interface des couches l et l-1 +c ds(l) : distance entre les couches l et l-1 en coord.s +c +c======================================================================= +c + REAL pa,preff + REAL ap(llmp1),bp(llmp1),dpres(llm),nivsigs(llm),nivsig(llmp1) + REAL presnivs(llm) +c +c declarations: +c ------------- +c + REAL sig(llm+1),dsig(llm) + real zzz(1:llm+1) + real dzz(1:llm) + real zk,zkm1,dzk1,dzk2,k0,k1 +c + INTEGER l + REAL snorm,dsigmin + REAL alpha,beta,gama,delta,deltaz,h + INTEGER np,ierr + REAL pi,x + + REAL SSUM +c +c----------------------------------------------------------------------- +c + pi=2.*ASIN(1.) + + OPEN(99,file='sigma.def',status='old',form='formatted', + s iostat=ierr) + +c----------------------------------------------------------------------- +c cas 1 on lit les options dans sigma.def: +c ---------------------------------------- + + IF (ierr.eq.0) THEN + + READ(99,*) h ! 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*h) + write(lunout,*)'h,alpha,k0,k1,beta' + +c read(*,*) h,deltaz,beta,k0,k1 ! 8 0.04 4 20 1.2 + + alpha=deltaz/tanh(1./k0)*2. + zkm1=0. + sig(1)=1. + do l=1,llm + sig(l+1)=(cosh(l/k0))**(-alpha*k0/h) + + *exp(-alpha/h*tanh((llm-k1)/k0)*beta**(l-(llm-k1))/log(beta)) + zk=-h*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. + +c + DO 2 l = 1, llm + dsig(l) = sig(l)-sig(l+1) + 2 CONTINUE +c + + ELSE +c----------------------------------------------------------------------- +c cas 2 ancienne discretisation (LMD5...): +c ---------------------------------------- + + WRITE(LUNOUT,*)'WARNING!!! Ancienne discretisation verticale' + + if (ok_strato) then + if (llm==39) then + dsigmin=0.3 + else if (llm==50) then + dsigmin=1. + else + WRITE(LUNOUT,*) 'ATTENTION discretisation z a ajuster' + dsigmin=1. + endif + WRITE(LUNOUT,*) 'Discretisation verticale DSIGMIN=',dsigmin + endif + + h=7. + snorm = 0. + DO l = 1, llm + x = 2.*asin(1.) * (REAL(l)-0.5) / REAL(llm+1) + + IF (ok_strato) THEN + dsig(l) =(dsigmin + 7.0 * SIN(x)**2) + & *(0.5*(1.-tanh(1.*(x-asin(1.))/asin(1.))))**2 + ELSE + dsig(l) = 1.0 + 7.0 * SIN(x)**2 + ENDIF + + snorm = snorm + dsig(l) + ENDDO + snorm = 1./snorm + DO l = 1, llm + dsig(l) = dsig(l)*snorm + ENDDO + sig(llm+1) = 0. + DO l = llm, 1, -1 + sig(l) = sig(l+1) + dsig(l) + ENDDO + + ENDIF + + + 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 +c ..... pa et preff sont lus sur les fichiers start par lectba ..... +c + + bp(llmp1) = 0. + + DO l = 1, llm +cc +ccc ap(l) = 0. +ccc bp(l) = sig(l) + + bp(l) = EXP( 1. -1./( sig(l)*sig(l)) ) + ap(l) = pa * ( sig(l) - bp(l) ) +c + ENDDO + + bp(1)=1. + ap(1)=0. + + ap(llmp1) = pa * ( sig(llmp1) - bp(llmp1) ) + + write(lunout,*)' BP ' + write(lunout,*) bp + write(lunout,*)' 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,*)'8km' + 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))*8. + . ,' DZ ~ ',8.*log((ap(l)+bp(l)*preff)/ + . max(ap(l+1)+bp(l+1)*preff,1.e-10)) + ENDDO + + write(lunout,*)' PRESNIVS ' + write(lunout,*)presnivs + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/diverg.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/diverg.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/diverg.F (revision 1632) @@ -0,0 +1,85 @@ +! +! $Header$ +! + SUBROUTINE diverg(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + +ccc CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c + DO l = 1, klevel + DO ij = iip2,ip1jm + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/diverg_gam.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/diverg_gam.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/diverg_gam.F (revision 1632) @@ -0,0 +1,80 @@ +! +! $Header$ +! + SUBROUTINE diverg_gam(klevel,cuvscvgam,cvuscugam,unsairegam , + * unsapolnga,unsapolsga, x, y, div ) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1) + REAL unsapolnga,unsapolsga +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER l,ij +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = ( + * cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + + * cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* + * unsairegam( ij+1 ) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvscvgam( ij ) * y( ij , l ) + aiy2(ij) = cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga + sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/diverg_gam_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/diverg_gam_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/diverg_gam_loc.F (revision 1632) @@ -0,0 +1,98 @@ + SUBROUTINE diverg_gam_loc(klevel,cuvscvgam,cvuscugam,unsairegam, + * unsapolnga,unsapolsga, x, y, div ) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + USE parallel + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel ) + REAL div( ijb_u:ije_u,klevel ) + REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1) + REAL unsapolnga,unsapolsga +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER l,ij +c ................................................................... +c + EXTERNAL SSUM + REAL SSUM + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + div( ij + 1, l ) = ( + * cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + + * cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* + * unsairegam( ij+1 ) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = ijb,ije,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + if (pole_nord) then + DO ij = 1,iim + aiy1(ij) = cuvscvgam( ij ) * y( ij , l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iim + aiy2(ij) = cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga +c + DO ij = 1,iip1 + div( ij + ip1jm, l ) = sumyps + ENDDO + endif + 10 CONTINUE +c$OMP END DO NOWAIT +c + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/diverg_gam_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/diverg_gam_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/diverg_gam_p.F (revision 1632) @@ -0,0 +1,97 @@ + SUBROUTINE diverg_gam_p(klevel,cuvscvgam,cvuscugam,unsairegam , + * unsapolnga,unsapolsga, x, y, div ) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + USE parallel + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + REAL cuvscvgam(ip1jm),cvuscugam(ip1jmp1),unsairegam(ip1jmp1) + REAL unsapolnga,unsapolsga +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER l,ij +c ................................................................... +c + EXTERNAL SSUM + REAL SSUM + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + div( ij + 1, l ) = ( + * cvuscugam( ij+1 ) * x( ij+1,l ) - cvuscugam( ij ) * x( ij , l) + + * cuvscvgam(ij-iim) * y(ij-iim,l) - cuvscvgam(ij+1) * y(ij+1,l) )* + * unsairegam( ij+1 ) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = ijb,ije,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + if (pole_nord) then + DO ij = 1,iim + aiy1(ij) = cuvscvgam( ij ) * y( ij , l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) * unsapolnga +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iim + aiy2(ij) = cuvscvgam( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumyps = SSUM ( iim,aiy2,1 ) * unsapolsga +c + DO ij = 1,iip1 + div( ij + ip1jm, l ) = sumyps + ENDDO + endif + 10 CONTINUE +c$OMP END DO NOWAIT +c + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/diverg_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/diverg_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/diverg_p.F (revision 1632) @@ -0,0 +1,106 @@ + SUBROUTINE diverg_p(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + USE parallel + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + INTEGER ijb,ije +c ................................................................... +c + EXTERNAL SSUM + REAL SSUM +c +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = ijb,ije,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + if (pole_nord) then + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iim + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij + ip1jm, l ) = sumyps + ENDDO + endif + + + 10 CONTINUE +c$OMP END DO NOWAIT +c + +ccc CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb,ije + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/divergf.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/divergf.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/divergf.F (revision 1632) @@ -0,0 +1,85 @@ +! +! $Header$ +! + SUBROUTINE divergf(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO ij = iip2, ip1jm - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + div( ij + ip1jm, l ) = sumyps + ENDDO + 10 CONTINUE +c + + CALL filtreg( div, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c + DO l = 1, klevel + DO ij = iip2,ip1jm + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/divergf_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/divergf_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/divergf_loc.F (revision 1632) @@ -0,0 +1,118 @@ + SUBROUTINE divergf_loc(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + USE PARALLEL + USE mod_filtreg_p + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ijb_u:ije_u,klevel ),y( ijb_v:ije_v,klevel ) + REAL div( ijb_u:ije_u,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + EXTERNAL SSUM + REAL SSUM + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO + +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = ijb,ije,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + if (pole_nord) then + + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + ENDDO + + endif + + if (pole_sud) then + + DO ij = 1,iim + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij + ip1jm, l ) = sumyps + ENDDO + + endif + + 10 CONTINUE +c$OMP END DO NOWAIT + +c + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p( div,jjb_u,jje_u,jjb,jje, jjp1, + & klevel, 2, 2, .TRUE., 1 ) + +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb,ije + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/divergf_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/divergf_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/divergf_p.F (revision 1632) @@ -0,0 +1,115 @@ + SUBROUTINE divergf_p(klevel,x,y,div) +c +c P. Le Van +c +c ********************************************************************* +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. +c x et y... +c x et y etant des composantes covariantes ... +c ********************************************************************* + USE PARALLEL + IMPLICIT NONE +c +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c --------------------------------------------------------------------- +c +c ATTENTION : pendant ce s-pg , ne pas toucher au COMMON/scratch/ . +c +c --------------------------------------------------------------------- +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c .......... variables en arguments ................... +c + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER l,ij +c +c ............... variables locales ......................... + + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps +c ................................................................... +c + EXTERNAL SSUM + REAL SSUM + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + div( ij + 1, l ) = + * cvusurcu( ij+1 ) * x( ij+1,l ) - cvusurcu( ij ) * x( ij , l) + + * cuvsurcv(ij-iim) * y(ij-iim,l) - cuvsurcv(ij+1) * y(ij+1,l) + ENDDO + +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO ij = ijb,ije,iip1 + div( ij,l ) = div( ij + iim,l ) + ENDDO +c +c .... calcul aux poles ..... +c + if (pole_nord) then + + DO ij = 1,iim + aiy1(ij) = cuvsurcv( ij ) * y( ij , l ) + ENDDO + sumypn = SSUM ( iim,aiy1,1 ) / apoln + +c + DO ij = 1,iip1 + div( ij , l ) = - sumypn + ENDDO + + endif + + if (pole_sud) then + + DO ij = 1,iim + aiy2(ij) = cuvsurcv( ij+ ip1jmi1 ) * y( ij+ ip1jmi1, l ) + ENDDO + sumyps = SSUM ( iim,aiy2,1 ) / apols +c + DO ij = 1,iip1 + div( ij + ip1jm, l ) = sumyps + ENDDO + + endif + + 10 CONTINUE +c$OMP END DO NOWAIT + +c + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p( div,jjb,jje, jjp1, klevel, 2, 2, .TRUE., 1 ) + +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb,ije + div(ij,l) = div(ij,l) * unsaire(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/divergst.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/divergst.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/divergst.F (revision 1632) @@ -0,0 +1,62 @@ +! +! $Header$ +! + SUBROUTINE divergst(klevel,x,y,div) + IMPLICIT NONE +c +c P. Le Van +c +c ****************************************************************** +c ... calcule la divergence a tous les niveaux d'1 vecteur de compos. x et y... +c x et y etant des composantes contravariantes ... +c **************************************************************** +c x et y sont des arguments d'entree pour le s-prog +c div est un argument de sortie pour le s-prog +c +c +c ------------------------------------------------------------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL x( ip1jmp1,klevel ),y( ip1jm,klevel ),div( ip1jmp1,klevel ) + INTEGER ij,l,i + REAL aiy1( iip1 ) , aiy2( iip1 ) + REAL sumypn,sumyps + + REAL SSUM +c +c + DO 10 l = 1,klevel +c + DO 1 ij = iip2, ip1jm - 1 + div( ij + 1, l ) = x(ij+1,l) - x(ij,l)+ y(ij-iim,l)-y(ij+1,l) + 1 CONTINUE +c +c .... correction pour div( 1,j,l) ...... +c .... div(1,j,l)= div(iip1,j,l) .... +c +CDIR$ IVDEP + DO 3 ij = iip2,ip1jm,iip1 + div( ij,l ) = div( ij + iim,l ) + 3 CONTINUE +c +c .... calcul aux poles ..... +c +c + DO 5 i = 1,iim + aiy1(i)= y(i,l) + aiy2(i)= y(i+ip1jmi1,l) + 5 CONTINUE + sumypn = SSUM ( iim,aiy1,1 ) + sumyps = SSUM ( iim,aiy2,1 ) + DO 7 i = 1,iip1 + div( i , l ) = - sumypn/iim + div( i + ip1jm, l ) = sumyps/iim + 7 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/divgrad.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/divgrad.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/divgrad.F (revision 1632) @@ -0,0 +1,56 @@ +! +! $Header$ +! + SUBROUTINE divgrad (klevel,h, lh, divgra ) + IMPLICIT NONE +c +c======================================================================= +c +c Auteur : P. Le Van +c ---------- +c +c lh +c calcul de (div( grad )) de h ..... +c h et lh sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c +c======================================================================= +c +c declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) + + INTEGER l,ij,iter,lh +c +c +c + CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 ) +c + DO 10 iter = 1,lh + + CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1 ) + + CALL grad (klevel,divgra, ghx , ghy ) + CALL diverg (klevel, ghx , ghy , divgra ) + + CALL filtreg ( divgra,jjp1,klevel,2,1,.true.,1) + + DO 5 l = 1,klevel + DO 4 ij = 1, ip1jmp1 + divgra( ij,l ) = - cdivh * divgra( ij,l ) + 4 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/divgrad2.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/divgrad2.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/divgrad2.F (revision 1632) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE divgrad2 ( klevel, h, deltapres, lh, divgra ) +c +c P. Le Van +c +c *************************************************************** +c +c ..... calcul de (div( grad )) de ( pext * h ) ..... +c **************************************************************** +c h ,klevel,lh et pext sont des arguments d'entree pour le s-prg +c divgra est un argument de sortie pour le s-prg +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comdissipn.h" + +c ....... variables en arguments ....... +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel ) + REAL divgra( ip1jmp1,klevel) +c +c ....... variables locales .......... +c + REAL signe, nudivgrs, sqrtps( ip1jmp1,llm ) + INTEGER l,ij,iter,lh +c ................................................................... + +c + signe = (-1.)**lh + nudivgrs = signe * cdivh + + CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 ) + +c + CALL laplacien( klevel, divgra, divgra ) + + DO l = 1, klevel + DO ij = 1, ip1jmp1 + sqrtps( ij,l ) = SQRT( deltapres(ij,l) ) + ENDDO + ENDDO +c + DO l = 1, klevel + DO ij = 1, ip1jmp1 + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO + +c ........ Iteration de l'operateur laplacien_gam ........ +c + DO iter = 1, lh - 2 + CALL laplacien_gam ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2, + * unsapolnga2, unsapolsga2, divgra, divgra ) + ENDDO +c +c ............................................................... + + DO l = 1, klevel + DO ij = 1, ip1jmp1 + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c + CALL laplacien ( klevel, divgra, divgra ) +c + DO l = 1,klevel + DO ij = 1,ip1jmp1 + divgra(ij,l) = nudivgrs * divgra(ij,l) / deltapres(ij,l) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/divgrad2_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/divgrad2_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/divgrad2_loc.F (revision 1632) @@ -0,0 +1,120 @@ + SUBROUTINE divgrad2_loc ( klevel, h, deltapres, lh, divgra_out ) +c +c P. Le Van +c +c *************************************************************** +c +c ..... calcul de (div( grad )) de ( pext * h ) ..... +c **************************************************************** +c h ,klevel,lh et pext sont des arguments d'entree pour le s-prg +c divgra est un argument de sortie pour le s-prg +c + USE parallel + USE times + USE mod_hallo + USE divgrad2_mod + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comdissipn.h" + +c ....... variables en arguments ....... +c + INTEGER klevel + REAL h( ijb_u:ije_u,klevel ), deltapres( ijb_u:ije_u,klevel ) + REAL divgra_out( ijb_u:ije_u,klevel) +c ....... variables locales .......... +c + REAL signe, nudivgrs, sqrtps( ijb_u:ije_u,llm ) + INTEGER l,ij,iter,lh +c ................................................................... + Type(Request) :: request_dissip + INTEGER ijb,ije + +c +c + signe = (-1.)**lh + nudivgrs = signe * cdivh + +c CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 ) + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + divgra(ijb:ije,l)=h(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT +c +c$OMP BARRIER + call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_loc( klevel, divgra, divgra ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + sqrtps( ij,l ) = SQRT( deltapres(ij,l) ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c ........ Iteration de l'operateur laplacien_gam ........ +c + DO iter = 1, lh - 2 +c$OMP BARRIER + call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + + CALL laplacien_gam_loc(klevel,cuvscvgam2,cvuscugam2,unsair_gam2, + * unsapolnga2, unsapolsga2, divgra, divgra ) + ENDDO +c +c ............................................................... + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c +c$OMP BARRIER + call Register_Hallo_u(divgra,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_loc ( klevel, divgra, divgra ) +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + DO ij = ijb,ije + divgra_out(ij,l) = nudivgrs * divgra(ij,l) / deltapres(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/divgrad2_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/divgrad2_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/divgrad2_mod.F90 (revision 1632) @@ -0,0 +1,33 @@ +MODULE divgrad2_mod + + REAL,POINTER,SAVE :: divgra( :,: ) + +CONTAINS + + SUBROUTINE divgrad2_allocate + USE bands + USE allocate_field + USE parallel + USE dimensions + IMPLICIT NONE + TYPE(distrib),POINTER :: d + d=>distrib_dissip + + CALL allocate_u(divgra,llm,d) + + + END SUBROUTINE divgrad2_allocate + + SUBROUTINE divgrad2_switch_dissip(dist) + USE allocate_field + USE bands + USE parallel + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(divgra,distrib_dissip,dist) + + + END SUBROUTINE divgrad2_switch_dissip + +END MODULE divgrad2_mod Index: /LMDZ5/trunk/libf/dyn3dmem/divgrad2_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/divgrad2_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/divgrad2_p.F (revision 1632) @@ -0,0 +1,120 @@ + SUBROUTINE divgrad2_p ( klevel, h, deltapres, lh, divgra_out ) +c +c P. Le Van +c +c *************************************************************** +c +c ..... calcul de (div( grad )) de ( pext * h ) ..... +c **************************************************************** +c h ,klevel,lh et pext sont des arguments d'entree pour le s-prg +c divgra est un argument de sortie pour le s-prg +c + USE parallel + USE times + USE mod_hallo + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comdissipn.h" + +c ....... variables en arguments ....... +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), deltapres( ip1jmp1,klevel ) + REAL divgra_out( ip1jmp1,klevel) + REAL,SAVE :: divgra( ip1jmp1,llm) + +c +c ....... variables locales .......... +c + REAL signe, nudivgrs, sqrtps( ip1jmp1,llm ) + INTEGER l,ij,iter,lh +c ................................................................... + Type(Request) :: request_dissip + INTEGER ijb,ije +c + signe = (-1.)**lh + nudivgrs = signe * cdivh + +c CALL SCOPY ( ip1jmp1 * klevel, h, 1, divgra, 1 ) + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + divgra(ijb:ije,l)=h(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT +c +c$OMP BARRIER + call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_p( klevel, divgra, divgra ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + sqrtps( ij,l ) = SQRT( deltapres(ij,l) ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c ........ Iteration de l'operateur laplacien_gam ........ +c + DO iter = 1, lh - 2 +c$OMP BARRIER + call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + + CALL laplacien_gam_p ( klevel,cuvscvgam2,cvuscugam2,unsair_gam2, + * unsapolnga2, unsapolsga2, divgra, divgra ) + ENDDO +c +c ............................................................... + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + divgra(ij,l) = divgra(ij,l) * sqrtps(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c +c$OMP BARRIER + call Register_Hallo(divgra,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_p ( klevel, divgra, divgra ) +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + DO ij = ijb,ije + divgra_out(ij,l) = nudivgrs * divgra(ij,l) / deltapres(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/divgrad_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/divgrad_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/divgrad_p.F (revision 1632) @@ -0,0 +1,91 @@ + SUBROUTINE divgrad_p (klevel,h, lh, divgra_out ) + USE parallel + USE times + IMPLICIT NONE +c +c======================================================================= +c +c Auteur : P. Le Van +c ---------- +c +c lh +c calcul de (div( grad )) de h ..... +c h et lh sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c +c======================================================================= +c +c declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL h( ip1jmp1,klevel ), divgra_out( ip1jmp1,klevel ) + REAL,SAVE :: divgra( ip1jmp1,llm ) + +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) + + INTEGER l,ij,iter,lh +c + INTEGER ijb,ije,jjb,jje +c +c +c CALL SCOPY ( ip1jmp1*klevel,h,1,divgra,1 ) + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + divgra(ijb:ije,l)=h(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT +c + +c + DO 10 iter = 1,lh + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1 ) + +c call exchange_Hallo(divgra,ip1jmp1,llm,0,1) +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(divgra,ip1jmp1,llm,1,1) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + CALL grad_p (klevel,divgra, ghx , ghy ) + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(ghy,ip1jm,llm,1,0) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL diverg_p (klevel, ghx , ghy , divgra ) + + jjb=jj_begin + jje=jj_end + CALL filtreg_p( divgra,jjb,jje,jjp1,klevel,2,1,.true.,1) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,klevel + DO 4 ij = ijb, ije + divgra_out( ij,l ) = - cdivh * divgra( ij,l ) + 4 CONTINUE + 5 CONTINUE +c$OMP END DO NOWAIT +c + 10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/dteta1_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dteta1_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dteta1_loc.F (revision 1632) @@ -0,0 +1,91 @@ + SUBROUTINE dteta1_loc ( teta, pbaru, pbarv, dteta) + USE parallel + USE write_field_p + USE mod_filtreg_p + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c Modif F.Forget 03/94 (on retire q et dq pour construire dteta1) +c +c ******************************************************************** +c ... calcul du terme de convergence horizontale du flux d'enthalpie +c potentielle ...... +c ******************************************************************** +c .. teta,pbaru et pbarv sont des arguments d'entree pour le s-pg .... +c dteta sont des arguments de sortie pour le s-pg .... +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" + + REAL teta( ijb_u:ije_u,llm ) + REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm) + REAL dteta( ijb_u:ije_u,llm ) + INTEGER l,ij + + REAL hbyv( ijb_v:ije_v,llm ), hbxu( ijb_u:ije_u,llm ) + +c + INTEGER ijb,ije,jjb,jje + + + jjb=jj_begin + jje=jj_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + ijb=ij_begin + ije=ij_end + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb, ije - 1 + hbxu(ij,l) = pbaru(ij,l) * 0.5 * ( teta(ij,l)+teta(ij+1,l) ) + 1 CONTINUE + +c .... correction pour hbxu(iip1,j,l) ..... +c .... hbxu(iip1,j,l)= hbxu(1,j,l) .... + +CDIR$ IVDEP + DO 2 ij = ijb+iip1-1, ije, iip1 + hbxu( ij, l ) = hbxu( ij - iim, l ) + 2 CONTINUE + + ijb=ij_begin-iip1 + if (pole_nord) ijb=ij_begin + + DO 3 ij = ijb,ije + hbyv(ij,l)= pbarv(ij, l)* 0.5 * ( teta(ij, l)+teta(ij+iip1,l) ) + 3 CONTINUE + + if (.not. pole_sud) then + hbxu(ije+1:ije+iip1,l) = 0 + hbyv(ije+1:ije+iip1,l) = 0 + endif + + 5 CONTINUE +c$OMP END DO NOWAIT + + + CALL convflu_loc ( hbxu, hbyv, llm, dteta ) + + +c stockage dans dh de la convergence horizont. filtree' du flux +c .... ........... +c d'enthalpie potentielle . + + + CALL filtreg_p( dteta,jjb_u,jje_u,jjb,jje,jjp1, llm, + & 2, 2, .true., 1) + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/dudv1_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dudv1_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dudv1_loc.F (revision 1632) @@ -0,0 +1,65 @@ + SUBROUTINE dudv1_loc ( vorpot, pbaru, pbarv, du, dv ) + USE parallel + IMPLICIT NONE +c +c----------------------------------------------------------------------- +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c calcul du terme de rotation +c ce terme est ajoute a d(ucov)/dt et a d(vcov)/dt .. +c vorpot, pbaru et pbarv sont des arguments d'entree pour le s-pg .. +c du et dv sont des arguments de sortie pour le s-pg .. +c +c----------------------------------------------------------------------- + +#include "dimensions.h" +#include "paramet.h" + + REAL vorpot( ijb_v:ije_v,llm ) ,pbaru( ijb_u:ije_u,llm ) , + * pbarv( ijb_v:ije_v,llm ) + REAL du( ijb_u:ije_u,llm ) ,dv( ijb_v:ije_v,llm ) + INTEGER l,ij,ijb,ije +c +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,llm +c + ijb=ij_begin + ije=ij_end + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 2 ij = ijb, ije-1 + du( ij,l ) = 0.125 *( vorpot(ij-iip1, l) + vorpot( ij, l) ) * + * ( pbarv(ij-iip1, l) + pbarv(ij-iim, l) + + * pbarv( ij , l) + pbarv(ij+ 1 , l) ) + 2 CONTINUE + + +c + if (pole_nord) ijb=ij_begin + + DO 3 ij = ijb, ije-1 + dv( ij+1,l ) = - 0.125 *( vorpot(ij, l) + vorpot(ij+1, l) ) * + * ( pbaru(ij, l) + pbaru(ij+1 , l) + + * pbaru(ij+iip1, l) + pbaru(ij+iip2, l) ) + 3 CONTINUE +c +c .... correction pour dv( 1,j,l ) ..... +c .... dv(1,j,l)= dv(iip1,j,l) .... +c +CDIR$ IVDEP + DO 4 ij = ijb, ije, iip1 + dv( ij,l ) = dv( ij + iim, l ) + 4 CONTINUE +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/dudv2_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dudv2_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dudv2_loc.F (revision 1632) @@ -0,0 +1,70 @@ + SUBROUTINE dudv2_loc ( teta, pkf, bern, du, dv ) + USE parallel + IMPLICIT NONE +c +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ***************************************************************** +c ..... calcul du terme de pression (gradient de p/densite ) et +c du terme de ( -gradient de la fonction de Bernouilli ) ... +c ***************************************************************** +c Ces termes sont ajoutes a d(ucov)/dt et a d(vcov)/dt .. +c +c +c teta , pkf, bern sont des arguments d'entree pour le s-pg .... +c du et dv sont des arguments de sortie pour le s-pg .... +c +c======================================================================= +c +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL teta( ijb_u:ije_u,llm ),pkf( ijb_u:ije_u,llm ) + REAL bern( ijb_u:ije_u,llm ) + REAL du( ijb_u:ije_u,llm ), dv( ijb_v:ije_v,llm ) + INTEGER l,ij,ijb,ije +c +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm +c + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + + DO 2 ij = ijb, ije - 1 + du(ij,l) = du(ij,l) + 0.5* ( teta( ij,l ) + teta( ij+1,l ) ) * + * ( pkf( ij,l ) - pkf(ij+1,l) ) + bern(ij,l) - bern(ij+1,l) + 2 CONTINUE +c +c +c ..... correction pour du(iip1,j,l), j=2,jjm ...... +c ... du(iip1,j,l) = du(1,j,l) ... +c +CDIR$ IVDEP + DO 3 ij = ijb+iip1-1, ije, iip1 + du( ij,l ) = du( ij - iim,l ) + 3 CONTINUE +c +c + if (pole_nord) ijb=ijb-iip1 + + DO 4 ij = ijb,ije + dv( ij,l) = dv(ij,l) + 0.5 * ( teta(ij,l) + teta( ij+iip1,l ) ) * + * ( pkf(ij+iip1,l) - pkf( ij,l ) ) + * + bern( ij+iip1,l ) - bern( ij ,l ) + 4 CONTINUE +c + 5 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/dump2d.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dump2d.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dump2d.F (revision 1632) @@ -0,0 +1,46 @@ +! +! $Id: dump2d.F 1279 2009-12-10 09:02:56Z fairhead $ +! + 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/dyn3dmem/dynetat0.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dynetat0.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dynetat0.F (revision 1632) @@ -0,0 +1,379 @@ +! +! $Header$ +! + SUBROUTINE dynetat0(fichnom,vcov,ucov, + . teta,q,masse,ps,phis,time) + USE infotrac + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van / L.Fairhead +c ------- +c +c objet: +c ------ +c +c Lecture de l'etat initial +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "temps.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" +#include "logic.h" + +c Arguments: +c ---------- + + CHARACTER*(*) fichnom + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot),masse(ip1jmp1,llm) + REAL ps(ip1jmp1),phis(ip1jmp1) + + REAL time + +c Variables +c + INTEGER length,iq + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr, nid, nvarid + +c----------------------------------------------------------------------- +c Ouverture NetCDF du fichier etat initial + + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start.nc' + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echoue pour " + CALL abort + ENDIF + + im = tab_cntrl(1) + jm = tab_cntrl(2) + lllm = tab_cntrl(3) + day_ref = tab_cntrl(4) + annee_ref = tab_cntrl(5) + rad = tab_cntrl(6) + omeg = tab_cntrl(7) + g = tab_cntrl(8) + cpp = tab_cntrl(9) + kappa = tab_cntrl(10) + daysec = tab_cntrl(11) + dtvr = tab_cntrl(12) + etot0 = tab_cntrl(13) + ptot0 = tab_cntrl(14) + ztot0 = tab_cntrl(15) + stot0 = tab_cntrl(16) + ang0 = tab_cntrl(17) + pa = tab_cntrl(18) + preff = tab_cntrl(19) +c + clon = tab_cntrl(20) + clat = tab_cntrl(21) + grossismx = tab_cntrl(22) + grossismy = tab_cntrl(23) +c + IF ( tab_cntrl(24).EQ.1. ) THEN + fxyhypb = . TRUE . +c dzoomx = tab_cntrl(25) +c dzoomy = tab_cntrl(26) +c taux = tab_cntrl(28) +c tauy = tab_cntrl(29) + ELSE + fxyhypb = . FALSE . + ysinus = . FALSE . + IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. + ENDIF + + day_ini = tab_cntrl(30) + itau_dyn = tab_cntrl(31) +c ................................................................. +c +c + PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa + + IF( im.ne.iim ) THEN + PRINT 1,im,iim + STOP + ELSE IF( jm.ne.jjm ) THEN + PRINT 2,jm,jjm + STOP + ELSE IF( lllm.ne.llm ) THEN + PRINT 3,lllm,llm + STOP + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour rlatv" + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "aire", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, aire) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "phisinit", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, phis) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, time) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ucov) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, vcov) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, teta) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + + DO iq=1,nqtot + ierr = NF_INQ_VARID (nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent" + PRINT*, " Il est donc initialise a zero" + q(:,:,iq)=0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q(1,1,iq)) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, q(1,1,iq)) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour "//tname(iq) + CALL abort + ENDIF + ENDIF + ENDDO + + ierr = NF_INQ_VARID (nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, masse) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ps) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_CLOSE(nid) + + day_ini=day_ini+INT(time) + time=time-INT(time) + + 1 FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree iim =',i4//) + 2 FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree jjm =',i4//) + 3 FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur parametree llm =',i4//) + 4 FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur dtinteg =',i4//) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/dynetat0_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dynetat0_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dynetat0_loc.F (revision 1632) @@ -0,0 +1,412 @@ +! +! $Header$ +! + SUBROUTINE dynetat0_loc(fichnom,vcov,ucov, + . teta,q,masse,ps,phis,time) + USE infotrac + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van / L.Fairhead +c ------- +c +c objet: +c ------ +c +c Lecture de l'etat initial +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "temps.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "ener.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" +#include "logic.h" + +c Arguments: +c ---------- + + CHARACTER*(*) fichnom + REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) + REAL teta(ijb_u:ije_u,llm) + REAL q(ijb_u:ije_u,llm,nqtot),masse(ijb_u:ije_u,llm) + REAL ps(ijb_u:ije_u),phis(ijb_u:ije_u) + + REAL time + +c Variables +c + INTEGER length,iq + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr, nid, nvarid + REAL,ALLOCATABLE :: vcov_glo(:,:),ucov_glo(:,:),teta_glo(:,:) + REAL,ALLOCATABLE :: q_glo(:,:),masse_glo(:,:),ps_glo(:) + REAL,ALLOCATABLE :: phis_glo(:) + +c----------------------------------------------------------------------- +c Ouverture NetCDF du fichier etat initial + + ierr = NF_OPEN (fichnom, NF_NOWRITE,nid) + IF (ierr.NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start.nc' + write(6,*)' ierr = ', ierr + CALL ABORT + ENDIF + +c + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echoue pour " + CALL abort + ENDIF + + im = tab_cntrl(1) + jm = tab_cntrl(2) + lllm = tab_cntrl(3) + day_ref = tab_cntrl(4) + annee_ref = tab_cntrl(5) + rad = tab_cntrl(6) + omeg = tab_cntrl(7) + g = tab_cntrl(8) + cpp = tab_cntrl(9) + kappa = tab_cntrl(10) + daysec = tab_cntrl(11) + dtvr = tab_cntrl(12) + etot0 = tab_cntrl(13) + ptot0 = tab_cntrl(14) + ztot0 = tab_cntrl(15) + stot0 = tab_cntrl(16) + ang0 = tab_cntrl(17) + pa = tab_cntrl(18) + preff = tab_cntrl(19) +c + clon = tab_cntrl(20) + clat = tab_cntrl(21) + grossismx = tab_cntrl(22) + grossismy = tab_cntrl(23) +c + IF ( tab_cntrl(24).EQ.1. ) THEN + fxyhypb = . TRUE . +c dzoomx = tab_cntrl(25) +c dzoomy = tab_cntrl(26) +c taux = tab_cntrl(28) +c tauy = tab_cntrl(29) + ELSE + fxyhypb = . FALSE . + ysinus = . FALSE . + IF( tab_cntrl(27).EQ.1. ) ysinus = . TRUE. + ENDIF + + day_ini = tab_cntrl(30) + itau_dyn = tab_cntrl(31) +c ................................................................. +c +c + PRINT*,'rad,omeg,g,cpp,kappa',rad,omeg,g,cpp,kappa + + IF( im.ne.iim ) THEN + PRINT 1,im,iim + STOP + ELSE IF( jm.ne.jjm ) THEN + PRINT 2,jm,jjm + STOP + ELSE IF( lllm.ne.llm ) THEN + PRINT 3,lllm,llm + STOP + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlonv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlonv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlonv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "rlatv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, rlatv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, rlatv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour rlatv" + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cu", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cu) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cu) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "cv", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, cv) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, cv) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "aire", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, aire) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, aire) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ALLOCATE(phis_glo(ip1jmp1)) + + ierr = NF_INQ_VARID (nid, "phisinit", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, phis_glo) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, phis_glo) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + phis(ijb_u:ije_u)=phis_glo(ijb_u:ije_u) + DEALLOCATE(phis_glo) + + ierr = NF_INQ_VARID (nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, time) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, time) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee " + CALL abort + ENDIF + + ierr = NF_INQ_VARID (nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF + + ALLOCATE(ucov_glo(ip1jmp1,llm)) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ucov_glo) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ucov_glo) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ucov(ijb_u:ije_u,:)=ucov_glo(ijb_u:ije_u,:) + DEALLOCATE(ucov_glo) + ALLOCATE(vcov_glo(ip1jm,llm)) + + ierr = NF_INQ_VARID (nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, vcov_glo) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, vcov_glo) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + vcov(ijb_v:ije_v,:)=vcov_glo(ijb_v:ije_v,:) + DEALLOCATE(vcov_glo) + ALLOCATE(teta_glo(ip1jmp1,llm)) + + ierr = NF_INQ_VARID (nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, teta_glo) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, teta_glo) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + teta(ijb_u:ije_u,:)=teta_glo(ijb_u:ije_u,:) + DEALLOCATE(teta_glo) + ALLOCATE(q_glo(ip1jmp1,llm)) + + + DO iq=1,nqtot + ierr = NF_INQ_VARID (nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ <"//tname(iq)//"> est absent" + PRINT*, " Il est donc initialise a zero" + q_glo(:,:)=0. + ELSE +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, q_glo) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, q_glo) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour "//tname(iq) + CALL abort + ENDIF + ENDIF + q(ijb_u:ije_u,:,iq)=q_glo(ijb_u:ije_u,:) + ENDDO + + DEALLOCATE(q_glo) + ALLOCATE(masse_glo(ip1jmp1,llm)) + + ierr = NF_INQ_VARID (nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, masse_glo) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, masse_glo) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + masse(ijb_u:ije_u,:)=masse_glo(ijb_u:ije_u,:) + DEALLOCATE(masse_glo) + ALLOCATE(ps_glo(ip1jmp1)) + + ierr = NF_INQ_VARID (nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Le champ est absent" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, ps_glo) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, ps_glo) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "dynetat0: Lecture echouee pour " + CALL abort + ENDIF + + ps(ijb_u:ije_u)=ps_glo(ijb_u:ije_u) + DEALLOCATE(ps_glo) + + ierr = NF_CLOSE(nid) + + day_ini=day_ini+INT(time) + time=time-INT(time) + + 1 FORMAT(//10x,'la valeur de im =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree iim =',i4//) + 2 FORMAT(//10x,'la valeur de jm =',i4,2x,'lue sur le fichier de dem + *arrage est differente de la valeur parametree jjm =',i4//) + 3 FORMAT(//10x,'la valeur de lmax =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur parametree llm =',i4//) + 4 FORMAT(//10x,'la valeur de dtrv =',i4,2x,'lue sur le fichier dema + *rrage est differente de la valeur dtinteg =',i4//) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/dynredem.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dynredem.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dynredem.F (revision 1632) @@ -0,0 +1,741 @@ +! +! $Id: dynredem.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c + SUBROUTINE dynredem0(fichnom,iday_end,phis) +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE infotrac + IMPLICIT NONE +c======================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF (initialisation) +c======================================================================= +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" + +c Arguments: +c ---------- + INTEGER iday_end + REAL phis(ip1jmp1) + CHARACTER*(*) fichnom + +c Local: +c ------ + INTEGER iq,l + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr + character*20 modname + character*80 abort_message + +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_s, idim_sig + INTEGER idim_tim + INTEGER nid,nvarid + + REAL zan0,zjulian,hours + INTEGER yyears0,jjour0, mmois0 + character*30 unites + + +c----------------------------------------------------------------------- + modname='dynredem0' + +#ifdef CPP_IOIPSL + call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) + call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) +#else +! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used) + yyears0=0 + mmois0=1 + jjour0=1 +#endif + + DO l=1,length + tab_cntrl(l) = 0. + ENDDO + tab_cntrl(1) = REAL(iim) + tab_cntrl(2) = REAL(jjm) + tab_cntrl(3) = REAL(llm) + tab_cntrl(4) = REAL(day_ref) + tab_cntrl(5) = REAL(annee_ref) + tab_cntrl(6) = rad + tab_cntrl(7) = omeg + tab_cntrl(8) = g + tab_cntrl(9) = cpp + tab_cntrl(10) = kappa + tab_cntrl(11) = daysec + tab_cntrl(12) = dtvr + tab_cntrl(13) = etot0 + tab_cntrl(14) = ptot0 + tab_cntrl(15) = ztot0 + tab_cntrl(16) = stot0 + tab_cntrl(17) = ang0 + tab_cntrl(18) = pa + tab_cntrl(19) = preff +c +c ..... parametres pour le zoom ...... + + tab_cntrl(20) = clon + tab_cntrl(21) = clat + tab_cntrl(22) = grossismx + tab_cntrl(23) = grossismy +c + IF ( fxyhypb ) THEN + tab_cntrl(24) = 1. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = taux + tab_cntrl(29) = tauy + ELSE + tab_cntrl(24) = 0. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = 0. + tab_cntrl(29) = 0. + IF( ysinus ) tab_cntrl(27) = 1. + ENDIF + + tab_cntrl(30) = REAL(iday_end) + tab_cntrl(31) = REAL(itau_dyn + itaufin) +c +c ......................................................... +c +c Creation du fichier: +c + ierr = NF_CREATE(fichnom, NF_CLOBBER, nid) + IF (ierr.NE.NF_NOERR) THEN + WRITE(6,*)" Pb d ouverture du fichier "//fichnom + WRITE(6,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier demmarage dynamique") +c +c Definir les dimensions du fichiers: +c + ierr = NF_DEF_DIM (nid, "index", length, idim_index) + ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s) + ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig) + ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim) +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition +c +c Definir et enregistrer certains champs invariants: +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Parametres de controle") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient A pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient B pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c +c Coefficients de passage cov. <-> contra. <--> naturel +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif +c +c Geopentiel au sol: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif +c +c Definir les variables pour pouvoir les enregistrer plus tard: +c + ierr = NF_REDEF (nid) ! entrer dans le mode de definition +c +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid) +#else + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Temps de simulation") + write(unites,200)yyears0,mmois0,jjour0 +200 format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00') + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30, + . unites) + +c + dims4(1) = idim_rlonu + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse U") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatv + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse V") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11, + . "Temperature") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim + IF(nqtot.GE.1) THEN + DO iq=1,nqtot +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) + ENDDO + ENDIF +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12, + . "C est quoi ?") +c + dims3(1) = idim_rlonv + dims3(2) = idim_rlatu + dims3(3) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, + . "Pression au sol") +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + ierr = NF_CLOSE(nid) ! fermer le fichier + + PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end + PRINT*,'rad,omeg,g,cpp,kappa', + , rad,omeg,g,cpp,kappa + + RETURN + END + SUBROUTINE dynredem1(fichnom,time, + . vcov,ucov,teta,q,masse,ps) + USE infotrac + USE control_mod + IMPLICIT NONE +c================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF +c================================================================= +#include "dimensions.h" +#include "paramet.h" +#include "description.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" + + INTEGER l + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot) + CHARACTER*(*) fichnom + + REAL time + INTEGER nid, nvarid, nid_trac, nvarid_trac + REAL trac_tmp(ip1jmp1,llm) + INTEGER ierr, ierr_file + INTEGER iq + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + character*20 modname + character*80 abort_message +c + INTEGER nb + SAVE nb + DATA nb / 0 / + + modname = 'dynredem1' + ierr = NF_OPEN(fichnom, NF_WRITE, nid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Pb. d ouverture "//fichnom + CALL abort + ENDIF + +c Ecriture/extension de la coordonnee temps + + nb = nb + 1 + ierr = NF_INQ_VARID(nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + print *, NF_STRERROR(ierr) + abort_message='Variable temps n est pas definie' + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time) +#else + ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time) +#endif + PRINT*, "Enregistrement pour ", nb, time + +c +c Re-ecriture du tableau de controle, itaufin n'est plus defini quand +c on passe dans dynredem0 + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Le champ est absent" + ierr = 1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + tab_cntrl(31) = REAL(itau_dyn + itaufin) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif + +c Ecriture des champs +c + ierr = NF_INQ_VARID(nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ucov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov) +#endif + + ierr = NF_INQ_VARID(nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable vcov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov) +#endif + + ierr = NF_INQ_VARID(nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable teta n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,teta) +#endif + + IF (config_inca /= 'none') THEN +! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc + ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac) + IF (ierr_file .NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start_trac.nc' + write(6,*)' ierr = ', ierr_file + ENDIF + END IF + + IF(nqtot.GE.1) THEN + do iq=1,nqtot + + IF (config_inca == 'none') THEN + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ELSE ! config_inca = 'chem' ou 'aero' +! lecture de la valeur du traceur dans start_trac.nc + IF (ierr_file .ne. 2) THEN + ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, tname(iq),"est absent de start_trac.nc" + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + + ELSE + PRINT*, tname(iq), "est present dans start_trac.nc" +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp) +#else + ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Lecture echouee pour", tname(iq) + CALL abort + ENDIF + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp) +#endif + + ENDIF ! IF (ierr .NE. NF_NOERR) +! fin lecture du traceur + ELSE ! si il n'y a pas de fichier start_trac.nc +! print *, 'il n y a pas de fichier start_trac' + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ENDIF ! (ierr_file .ne. 2) + END IF ! config_inca + + ENDDO + ENDIF +c + ierr = NF_INQ_VARID(nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable masse n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,masse) +#endif +c + ierr = NF_INQ_VARID(nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ps n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ps) +#endif + + ierr = NF_CLOSE(nid) +c + RETURN + END + Index: /LMDZ5/trunk/libf/dyn3dmem/dynredem_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dynredem_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dynredem_loc.F (revision 1632) @@ -0,0 +1,683 @@ +! +! $Id: dynredem_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c + SUBROUTINE dynredem0_loc(fichnom,iday_end,phis) +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE parallel + USE mod_hallo + USE infotrac + IMPLICIT NONE +c======================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF (initialisation) +c======================================================================= +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" + +c Arguments: +c ---------- + INTEGER iday_end + REAL phis(ijb_u:ije_u) + CHARACTER*(*) fichnom + +c Local: +c ------ + INTEGER iq,l + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr + character*20 modname + character*80 abort_message + +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_s, idim_sig + INTEGER idim_tim + INTEGER nid,nvarid + + REAL zan0,zjulian,hours + INTEGER yyears0,jjour0, mmois0 + character*30 unites + REAL :: phis_glo(ip1jmp1) + + CALL Gather_field_u(phis,phis_glo,1) + + +c----------------------------------------------------------------------- + if (mpi_rank==0) then + + modname='dynredem0_p' + +#ifdef CPP_IOIPSL + call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) + call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) +#else +! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used) + yyears0=0 + mmois0=1 + jjour0=1 +#endif + + DO l=1,length + tab_cntrl(l) = 0. + ENDDO + tab_cntrl(1) = REAL(iim) + tab_cntrl(2) = REAL(jjm) + tab_cntrl(3) = REAL(llm) + tab_cntrl(4) = REAL(day_ref) + tab_cntrl(5) = REAL(annee_ref) + tab_cntrl(6) = rad + tab_cntrl(7) = omeg + tab_cntrl(8) = g + tab_cntrl(9) = cpp + tab_cntrl(10) = kappa + tab_cntrl(11) = daysec + tab_cntrl(12) = dtvr + tab_cntrl(13) = etot0 + tab_cntrl(14) = ptot0 + tab_cntrl(15) = ztot0 + tab_cntrl(16) = stot0 + tab_cntrl(17) = ang0 + tab_cntrl(18) = pa + tab_cntrl(19) = preff +c +c ..... parametres pour le zoom ...... + + tab_cntrl(20) = clon + tab_cntrl(21) = clat + tab_cntrl(22) = grossismx + tab_cntrl(23) = grossismy +c + IF ( fxyhypb ) THEN + tab_cntrl(24) = 1. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = taux + tab_cntrl(29) = tauy + ELSE + tab_cntrl(24) = 0. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = 0. + tab_cntrl(29) = 0. + IF( ysinus ) tab_cntrl(27) = 1. + ENDIF + + tab_cntrl(30) = REAL(iday_end) + tab_cntrl(31) = REAL(itau_dyn + itaufin) +c +c ......................................................... +c +c Creation du fichier: +c + ierr = NF_CREATE(fichnom, NF_CLOBBER, nid) + IF (ierr.NE.NF_NOERR) THEN + WRITE(6,*)" Pb d ouverture du fichier "//fichnom + WRITE(6,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier demmarage dynamique") +c +c Definir les dimensions du fichiers: +c + ierr = NF_DEF_DIM (nid, "index", length, idim_index) + ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s) + ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig) + ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim) +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition +c +c Definir et enregistrer certains champs invariants: +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Parametres de controle") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient A pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient B pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c +c Coefficients de passage cov. <-> contra. <--> naturel +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif +c +c Geopentiel au sol: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis_glo) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis_glo) +#endif +c +c Definir les variables pour pouvoir les enregistrer plus tard: +c + ierr = NF_REDEF (nid) ! entrer dans le mode de definition +c +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid) +#else + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Temps de simulation") + write(unites,200)yyears0,mmois0,jjour0 +200 format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00') + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30, + . unites) + +c + dims4(1) = idim_rlonu + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse U") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatv + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse V") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11, + . "Temperature") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim + + DO iq=1,nqtot +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) + ENDDO +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12, + . "C est quoi ?") +c + dims3(1) = idim_rlonv + dims3(2) = idim_rlatu + dims3(3) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, + . "Pression au sol") +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + ierr = NF_CLOSE(nid) ! fermer le fichier + + + PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end + PRINT*,'rad,omeg,g,cpp,kappa', + , rad,omeg,g,cpp,kappa + + endif ! mpi_rank==0 + RETURN + END + SUBROUTINE dynredem1_loc(fichnom,time, + . vcov,ucov,teta,q,masse,ps) + USE parallel + USE mod_hallo + USE infotrac + USE control_mod + USE dynredem_mod + IMPLICIT NONE +c================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF +c================================================================= +#include "dimensions.h" +#include "paramet.h" +#include "description.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" + + INTEGER l + REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) + REAL teta(ijb_u:ije_u,llm) + REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm) + REAL q(ijb_u:ije_u,llm,nqtot) + CHARACTER*(*) fichnom + + REAL time + INTEGER nid, nvarid, nid_trac, nvarid_trac + REAL trac_tmp(ijb_u:ije_u,llm) + INTEGER ierr, ierr_file + INTEGER iq + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + character*20 modname + character*80 abort_message +c + INTEGER nb + SAVE nb + DATA nb / 0 / + REAL,SAVE,ALLOCATABLE :: ucov_glo(:,:),vcov_glo(:,:),teta_glo(:,:) + REAL,SAVE,ALLOCATABLE :: masse_glo(:,:),ps_glo(:),q_glo(:,:) + LOGICAL,SAVE :: exist_file + INTEGER,SAVE :: ierr_var + +! call Gather_Field(ucov,ip1jmp1,llm,0) +! call Gather_Field(vcov,ip1jm,llm,0) +! call Gather_Field(teta,ip1jmp1,llm,0) +! call Gather_Field(masse,ip1jmp1,llm,0) +! call Gather_Field(ps,ip1jmp1,1,0) + +! do iq=1,nqtot +! call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + ! enddo + +!$OMP MASTER + if (mpi_rank==0) then + modname = 'dynredem1' + ierr = NF_OPEN(fichnom, NF_WRITE, nid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Pb. d ouverture "//fichnom + CALL abort + ENDIF + +c Ecriture/extension de la coordonnee temps + + nb = nb + 1 + ierr = NF_INQ_VARID(nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + print *, NF_STRERROR(ierr) + abort_message='Variable temps n est pas definie' + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time) +#else + ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time) +#endif + PRINT*, "Enregistrement pour ", nb, time + +c +c Re-ecriture du tableau de controle, itaufin n'est plus defini quand +c on passe dans dynredem0 + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Le champ est absent" + ierr = 1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + tab_cntrl(31) = REAL(itau_dyn + itaufin) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif + endif +!$OMP END MASTER + +! + CALL dynredem_write_u(nid,"ucov",ucov,llm) + CALL dynredem_write_v(nid,"vcov",vcov,llm) + CALL dynredem_write_u(nid,"teta",teta,llm) + CALL dynredem_write_u(nid,"masse",masse,llm) + CALL dynredem_write_u(nid,"ps",ps,1) + + IF (config_inca == 'none') THEN + DO iq=1,nqtot + CALL dynredem_write_u(nid,tname(iq),q(:,:,iq),llm) + ENDDO + ELSE + +!$OMP MASTER + INQUIRE(FILE="start_trac.nc", EXIST=exist_file) + PRINT *, "EXIST", exist_file +!$OMP END MASTER +!$OMP BARRIER + + IF (exist_file) THEN +!$OMP MASTER + ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac) + IF (ierr_file .NE.NF_NOERR) THEN + WRITE(6,*)' Pb d''ouverture du fichier start_trac.nc' + WRITE(6,*)' ierr = ', ierr_file + ENDIF +!$OMP END MASTER + + DO iq=1,nqtot + +!$OMP MASTER + ierr_var = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac) +!$OMP END MASTER +!$OMP BARRIER + IF (ierr == NF_NOERR) THEN + CALL dynredem_read_u(nid_trac,tname(iq),q(:,:,iq),llm) + ENDIF + CALL dynredem_write_u(nid,tname(iq),q(:,:,iq),llm) + ENDDO + + ELSE ! pas de fichier start_tract + DO iq=1,nqtot + CALL dynredem_write_u(nid,tname(iq),q(:,:,iq),llm) + ENDDO + ENDIF + ENDIF + + +!$OMP MASTER + IF (mpi_rank==0) THEN + ierr = NF_CLOSE(nid) + ENDIF ! mpi_rank==0 +!$OMP END MASTER + + RETURN + END + Index: /LMDZ5/trunk/libf/dyn3dmem/dynredem_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dynredem_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dynredem_mod.F90 (revision 1632) @@ -0,0 +1,213 @@ +MODULE dynredem_mod + + + + + +CONTAINS + + SUBROUTINE dynredem_write_u(ncid,id,var,ll) + USE dimensions + USE parallel + USE mod_hallo + IMPLICIT NONE + INTEGER :: ncid + CHARACTER(LEN=*) :: id + REAL :: var(ijb_u:ije_u,ll) + REAL,ALLOCATABLE,SAVE :: var_tmp(:,:) + REAL,ALLOCATABLE,SAVE :: var_glo(:) + INTEGER :: ll + INTEGER :: count(4) + INTEGER :: start(4) + INTEGER :: l + INTEGER :: nvarid + INTEGER :: ierr + INCLUDE 'netcdf.inc' + + count(:)=(/ iip1,jjp1,1,1 /) + start(:)=(/ 1,1,1,1 /) + +!$OMP MASTER + IF (mpi_rank==0) THEN + ierr = NF_INQ_VARID(ncid, id, nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable "//id//" n est pas definie" + CALL abort + ENDIF + ENDIF +!$OMP END MASTER + + ll=size(var,2) + +!$OMP MASTER + ALLOCATE(var_tmp(ijb_u:ije_u,ll)) + ALLOCATE(var_glo(ip1jmp1)) +!$OMP END MASTER +!$OMP BARRIER + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,ll + var_tmp(:,l)=var(:,l) + ENDDO + + DO l=1,ll + CALL gather_field_u(var_tmp(:,l),var_glo,1) + IF (mpi_rank==0) THEN + !$OMP MASTER + start(3)=l +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE (ncid,nvarid,start,count,var_glo) +#else + ierr = NF_PUT_VARA_REAL (ncid,nvarid,start,count,var_glo) +#endif + !$OMP END MASTER + ENDIF + ENDDO + + !$OMP BARRIER + !$OMP MASTER + DEALLOCATE(var_tmp) + DEALLOCATE(var_glo) + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE dynredem_write_u + + SUBROUTINE dynredem_write_v(ncid,id,var,ll) + USE dimensions + USE parallel + USE mod_hallo + IMPLICIT NONE + INTEGER :: ncid + CHARACTER(LEN=*) :: id + REAL :: var(ijb_v:ije_v,ll) + REAL,ALLOCATABLE,SAVE :: var_tmp(:,:) + REAL,ALLOCATABLE,SAVE :: var_glo(:) + INTEGER :: ll + INTEGER :: count(4) + INTEGER :: start(4) + INTEGER :: l + INTEGER :: nvarid + INTEGER :: ierr + INCLUDE 'netcdf.inc' + + count(:)=(/ iip1,jjm,1,1 /) + start(:)=(/ 1,1,1,1 /) + +!$OMP MASTER + IF (mpi_rank==0) THEN + ierr = NF_INQ_VARID(ncid, id, nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable "//id//" n est pas definie" + CALL abort + ENDIF + ENDIF +!$OMP END MASTER + + ll=size(var,2) + +!$OMP MASTER + ALLOCATE(var_tmp(ijb_v:ije_v,ll)) + ALLOCATE(var_glo(ip1jm)) +!$OMP END MASTER +!$OMP BARRIER + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,ll + var_tmp(:,l)=var(:,l) + ENDDO + + DO l=1,ll + CALL gather_field_v(var_tmp(:,l),var_glo,1) + IF (mpi_rank==0) THEN + !$OMP MASTER + start(3)=l +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE (ncid,nvarid,start,count,var_glo) +#else + ierr = NF_PUT_VARA_REAL (ncid,nvarid,start,count,var_glo) +#endif + !$OMP END MASTER + ENDIF + ENDDO + + !$OMP BARRIER + !$OMP MASTER + DEALLOCATE(var_tmp) + DEALLOCATE(var_glo) + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE dynredem_write_v + + SUBROUTINE dynredem_read_u(ncid,id,var,ll) + USE dimensions + USE parallel + USE mod_hallo + IMPLICIT NONE + INTEGER :: ncid + CHARACTER(LEN=*) :: id + REAL :: var(ijb_u:ije_u,ll) + REAL,ALLOCATABLE,SAVE :: var_tmp(:,:) + REAL,ALLOCATABLE,SAVE :: var_glo(:) + INTEGER :: ll + INTEGER :: count(4) + INTEGER :: start(4) + INTEGER :: l + INTEGER :: nvarid + INTEGER :: ierr + INCLUDE 'netcdf.inc' + + count(:)=(/ iip1,jjp1,1,1 /) + start(:)=(/ 1,1,1,1 /) + +!$OMP MASTER + IF (mpi_rank==0) THEN + ierr = NF_INQ_VARID(ncid, id, nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable "//id//" n est pas definie" + CALL abort + ENDIF + ENDIF +!$OMP END MASTER + + ll=size(var,2) + +!$OMP MASTER + ALLOCATE(var_tmp(ijb_u:ije_u,ll)) + ALLOCATE(var_glo(ip1jmp1)) +!$OMP END MASTER +!$OMP BARRIER + + + DO l=1,ll + IF (mpi_rank==0) THEN + !$OMP MASTER + start(3)=l +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE (ncid,nvarid,start,count,var_glo) +#else + ierr = NF_GET_VARA_REAL (ncid,nvarid,start,count,var_glo) +#endif + !$OMP END MASTER + ENDIF + CALL scatter_field_u(var_glo,var_tmp(:,l),1) + ENDDO + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,ll + var(:,l)=var_tmp(:,l) + ENDDO + + !$OMP BARRIER + !$OMP MASTER + DEALLOCATE(var_tmp) + DEALLOCATE(var_glo) + !$OMP END MASTER + !$OMP BARRIER + + END SUBROUTINE dynredem_read_u + +END MODULE dynredem_mod + + Index: /LMDZ5/trunk/libf/dyn3dmem/dynredem_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/dynredem_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/dynredem_p.F (revision 1632) @@ -0,0 +1,769 @@ +! +! $Id: dynredem_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c + SUBROUTINE dynredem0_p(fichnom,iday_end,phis) +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + USE parallel + USE infotrac + IMPLICIT NONE +c======================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF (initialisation) +c======================================================================= +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "netcdf.inc" +#include "description.h" +#include "serre.h" + +c Arguments: +c ---------- + INTEGER iday_end + REAL phis(ip1jmp1) + CHARACTER*(*) fichnom + +c Local: +c ------ + INTEGER iq,l + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + INTEGER ierr + character*20 modname + character*80 abort_message + +c Variables locales pour NetCDF: +c + INTEGER dims2(2), dims3(3), dims4(4) + INTEGER idim_index + INTEGER idim_rlonu, idim_rlonv, idim_rlatu, idim_rlatv + INTEGER idim_s, idim_sig + INTEGER idim_tim + INTEGER nid,nvarid + + REAL zan0,zjulian,hours + INTEGER yyears0,jjour0, mmois0 + character*30 unites + +c----------------------------------------------------------------------- + if (mpi_rank==0) then + + modname='dynredem0_p' + +#ifdef CPP_IOIPSL + call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian) + call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours) +#else +! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used) + yyears0=0 + mmois0=1 + jjour0=1 +#endif + + DO l=1,length + tab_cntrl(l) = 0. + ENDDO + tab_cntrl(1) = REAL(iim) + tab_cntrl(2) = REAL(jjm) + tab_cntrl(3) = REAL(llm) + tab_cntrl(4) = REAL(day_ref) + tab_cntrl(5) = REAL(annee_ref) + tab_cntrl(6) = rad + tab_cntrl(7) = omeg + tab_cntrl(8) = g + tab_cntrl(9) = cpp + tab_cntrl(10) = kappa + tab_cntrl(11) = daysec + tab_cntrl(12) = dtvr + tab_cntrl(13) = etot0 + tab_cntrl(14) = ptot0 + tab_cntrl(15) = ztot0 + tab_cntrl(16) = stot0 + tab_cntrl(17) = ang0 + tab_cntrl(18) = pa + tab_cntrl(19) = preff +c +c ..... parametres pour le zoom ...... + + tab_cntrl(20) = clon + tab_cntrl(21) = clat + tab_cntrl(22) = grossismx + tab_cntrl(23) = grossismy +c + IF ( fxyhypb ) THEN + tab_cntrl(24) = 1. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = taux + tab_cntrl(29) = tauy + ELSE + tab_cntrl(24) = 0. + tab_cntrl(25) = dzoomx + tab_cntrl(26) = dzoomy + tab_cntrl(27) = 0. + tab_cntrl(28) = 0. + tab_cntrl(29) = 0. + IF( ysinus ) tab_cntrl(27) = 1. + ENDIF + + tab_cntrl(30) = REAL(iday_end) + tab_cntrl(31) = REAL(itau_dyn + itaufin) +c +c ......................................................... +c +c Creation du fichier: +c + ierr = NF_CREATE(fichnom, NF_CLOBBER, nid) + IF (ierr.NE.NF_NOERR) THEN + WRITE(6,*)" Pb d ouverture du fichier "//fichnom + WRITE(6,*)' ierr = ', ierr + CALL ABORT + ENDIF +c +c Preciser quelques attributs globaux: +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 27, + . "Fichier demmarage dynamique") +c +c Definir les dimensions du fichiers: +c + ierr = NF_DEF_DIM (nid, "index", length, idim_index) + ierr = NF_DEF_DIM (nid, "rlonu", iip1, idim_rlonu) + ierr = NF_DEF_DIM (nid, "rlatu", jjp1, idim_rlatu) + ierr = NF_DEF_DIM (nid, "rlonv", iip1, idim_rlonv) + ierr = NF_DEF_DIM (nid, "rlatv", jjm, idim_rlatv) + ierr = NF_DEF_DIM (nid, "sigs", llm, idim_s) + ierr = NF_DEF_DIM (nid, "sig", llmp1, idim_sig) + ierr = NF_DEF_DIM (nid, "temps", NF_UNLIMITED, idim_tim) +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition +c +c Definir et enregistrer certains champs invariants: +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"controle",NF_DOUBLE,1,idim_index,nvarid) +#else + ierr = NF_DEF_VAR (nid,"controle",NF_FLOAT,1,idim_index,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Parametres de controle") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonu",NF_DOUBLE,1,idim_rlonu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonu",NF_FLOAT,1,idim_rlonu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatu",NF_DOUBLE,1,idim_rlatu,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatu",NF_FLOAT,1,idim_rlatu,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlonv",NF_DOUBLE,1,idim_rlonv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlonv",NF_FLOAT,1,idim_rlonv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 23, + . "Longitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"rlatv",NF_DOUBLE,1,idim_rlatv,nvarid) +#else + ierr = NF_DEF_VAR (nid,"rlatv",NF_FLOAT,1,idim_rlatv,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Latitudes des points V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatv) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsigs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsigs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 28, + . "Numero naturel des couches s") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsigs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsigs) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"nivsig",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"nivsig",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 32, + . "Numero naturel des couches sigma") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,nivsig) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,nivsig) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ap",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ap",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient A pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ap) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ap) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"bp",NF_DOUBLE,1,idim_sig,nvarid) +#else + ierr = NF_DEF_VAR (nid,"bp",NF_FLOAT,1,idim_sig,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 26, + . "Coefficient B pour hybride") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,bp) +#endif +c + ierr = NF_REDEF (nid) +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"presnivs",NF_DOUBLE,1,idim_s,nvarid) +#else + ierr = NF_DEF_VAR (nid,"presnivs",NF_FLOAT,1,idim_s,nvarid) +#endif +cIM 220306 END + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,presnivs) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,presnivs) +#endif +c +c Coefficients de passage cov. <-> contra. <--> naturel +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonu + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cu",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cu",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour U") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cu) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cu) +#endif +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatv +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"cv",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"cv",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 29, + . "Coefficient de passage pour V") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,cv) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,cv) +#endif +c +c Aire de chaque maille: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"aire",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"aire",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 22, + . "Aires de chaque maille") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aire) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,aire) +#endif +c +c Geopentiel au sol: +c + ierr = NF_REDEF (nid) + dims2(1) = idim_rlonv + dims2(2) = idim_rlatu +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"phisinit",NF_DOUBLE,2,dims2,nvarid) +#else + ierr = NF_DEF_VAR (nid,"phisinit",NF_FLOAT,2,dims2,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Geopotentiel au sol") + ierr = NF_ENDDEF(nid) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,phis) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,phis) +#endif +c +c Definir les variables pour pouvoir les enregistrer plus tard: +c + ierr = NF_REDEF (nid) ! entrer dans le mode de definition +c +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"temps",NF_DOUBLE,1,idim_tim,nvarid) +#else + ierr = NF_DEF_VAR (nid,"temps",NF_FLOAT,1,idim_tim,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 19, + . "Temps de simulation") + write(unites,200)yyears0,mmois0,jjour0 +200 format('days since ',i4,'-',i2.2,'-',i2.2,' 00:00:00') + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "units", 30, + . unites) + +c + dims4(1) = idim_rlonu + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ucov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ucov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse U") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatv + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"vcov",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"vcov",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 9, + . "Vitesse V") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"teta",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"teta",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 11, + . "Temperature") +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim + + DO iq=1,nqtot +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,tname(iq),NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,tname(iq),NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq)) + ENDDO +c + dims4(1) = idim_rlonv + dims4(2) = idim_rlatu + dims4(3) = idim_s + dims4(4) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"masse",NF_DOUBLE,4,dims4,nvarid) +#else + ierr = NF_DEF_VAR (nid,"masse",NF_FLOAT,4,dims4,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12, + . "C est quoi ?") +c + dims3(1) = idim_rlonv + dims3(2) = idim_rlatu + dims3(3) = idim_tim +cIM 220306 BEG +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid,"ps",NF_DOUBLE,3,dims3,nvarid) +#else + ierr = NF_DEF_VAR (nid,"ps",NF_FLOAT,3,dims3,nvarid) +#endif +cIM 220306 END + ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 15, + . "Pression au sol") +c + ierr = NF_ENDDEF(nid) ! sortir du mode de definition + ierr = NF_CLOSE(nid) ! fermer le fichier + + + PRINT*,'iim,jjm,llm,iday_end',iim,jjm,llm,iday_end + PRINT*,'rad,omeg,g,cpp,kappa', + , rad,omeg,g,cpp,kappa + + endif ! mpi_rank==0 + RETURN + END + SUBROUTINE dynredem1_p(fichnom,time, + . vcov,ucov,teta,q,masse,ps) + USE parallel + USE infotrac + USE control_mod + IMPLICIT NONE +c================================================================= +c Ecriture du fichier de redemarrage sous format NetCDF +c================================================================= +#include "dimensions.h" +#include "paramet.h" +#include "description.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" + + INTEGER l + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL q(ip1jmp1,llm,nqtot) + CHARACTER*(*) fichnom + + REAL time + INTEGER nid, nvarid, nid_trac, nvarid_trac + REAL trac_tmp(ip1jmp1,llm) + INTEGER ierr, ierr_file + INTEGER iq + INTEGER length + PARAMETER (length = 100) + REAL tab_cntrl(length) ! tableau des parametres du run + character*20 modname + character*80 abort_message +c + INTEGER nb + SAVE nb + DATA nb / 0 / + + logical exist_file + + call Gather_Field(ucov,ip1jmp1,llm,0) + call Gather_Field(vcov,ip1jm,llm,0) + call Gather_Field(teta,ip1jmp1,llm,0) + call Gather_Field(masse,ip1jmp1,llm,0) + call Gather_Field(ps,ip1jmp1,1,0) + + do iq=1,nqtot + call Gather_Field(q(1,1,iq),ip1jmp1,llm,0) + enddo + + + if (mpi_rank==0) then + + modname = 'dynredem1' + ierr = NF_OPEN(fichnom, NF_WRITE, nid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Pb. d ouverture "//fichnom + CALL abort + ENDIF + +c Ecriture/extension de la coordonnee temps + + nb = nb + 1 + ierr = NF_INQ_VARID(nid, "temps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + print *, NF_STRERROR(ierr) + abort_message='Variable temps n est pas definie' + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,nvarid,nb,time) +#else + ierr = NF_PUT_VAR1_REAL (nid,nvarid,nb,time) +#endif + PRINT*, "Enregistrement pour ", nb, time + +c +c Re-ecriture du tableau de controle, itaufin n'est plus defini quand +c on passe dans dynredem0 + ierr = NF_INQ_VARID (nid, "controle", nvarid) + IF (ierr .NE. NF_NOERR) THEN + abort_message="dynredem1: Le champ est absent" + ierr = 1 + CALL abort_gcm(modname,abort_message,ierr) + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid, nvarid, tab_cntrl) +#else + ierr = NF_GET_VAR_REAL(nid, nvarid, tab_cntrl) +#endif + tab_cntrl(31) = REAL(itau_dyn + itaufin) +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,tab_cntrl) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,tab_cntrl) +#endif + +c Ecriture des champs +c + ierr = NF_INQ_VARID(nid, "ucov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ucov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ucov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ucov) +#endif + + ierr = NF_INQ_VARID(nid, "vcov", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable vcov n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,vcov) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,vcov) +#endif + + ierr = NF_INQ_VARID(nid, "teta", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable teta n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,teta) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,teta) +#endif + + IF (config_inca /= 'none') THEN +! Ajout Anne pour lecture valeurs traceurs dans un fichier start_trac.nc + inquire(FILE="start_trac.nc", EXIST=exist_file) + print *, "EXIST", exist_file + if (exist_file) then + ierr_file = NF_OPEN ("start_trac.nc", NF_NOWRITE,nid_trac) + IF (ierr_file .NE.NF_NOERR) THEN + write(6,*)' Pb d''ouverture du fichier start_trac.nc' + write(6,*)' ierr = ', ierr_file + ENDIF + else + ierr_file = 2 + endif + END IF + + do iq=1,nqtot + + IF (config_inca == 'none') THEN + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ELSE ! config_inca = 'chem' ou 'aero' +! lecture de la valeur du traceur dans start_trac.nc + IF (ierr_file .ne. 2) THEN + ierr = NF_INQ_VARID (nid_trac, tname(iq), nvarid_trac) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, tname(iq),"est absent de start_trac.nc" + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + + ELSE + PRINT*, tname(iq), "est present dans start_trac.nc" +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(nid_trac, nvarid_trac, trac_tmp) +#else + ierr = NF_GET_VAR_REAL(nid_trac, nvarid_trac, trac_tmp) +#endif + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Lecture echouee pour", tname(iq) + CALL abort + ENDIF + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ", tname(iq)," n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,trac_tmp) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,trac_tmp) +#endif + + ENDIF ! IF (ierr .NE. NF_NOERR) +! fin lecture du traceur + ELSE ! si il n'y a pas de fichier start_trac.nc +! print *, 'il n y a pas de fichier start_trac' + ierr = NF_INQ_VARID(nid, tname(iq), nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable tname(iq) n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,q(1,1,iq)) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,q(1,1,iq)) +#endif + ENDIF ! (ierr_file .ne. 2) + END IF ! config_inca + + ENDDO + + + +c + ierr = NF_INQ_VARID(nid, "masse", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable masse n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,masse) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,masse) +#endif +c + ierr = NF_INQ_VARID(nid, "ps", nvarid) + IF (ierr .NE. NF_NOERR) THEN + PRINT*, "Variable ps n est pas definie" + CALL abort + ENDIF +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,ps) +#else + ierr = NF_PUT_VAR_REAL (nid,nvarid,ps) +#endif + + ierr = NF_CLOSE(nid) +c + endif ! mpi_rank==0 + + RETURN + END + Index: /LMDZ5/trunk/libf/dyn3dmem/ener.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/ener.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/ener.h (revision 1632) @@ -0,0 +1,14 @@ +! +! $Header$ +! +!----------------------------------------------------------------------- +! 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/dyn3dmem/enercin.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/enercin.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/enercin.F (revision 1632) @@ -0,0 +1,98 @@ +! +! $Header$ +! + SUBROUTINE enercin ( vcov, ucov, vcont, ucont, ecin ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .. calcul de l'energie cinetique aux niveaux s ...... +c ********************************************************************* +c vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg . +c ecin est un argument de sortie pour le s-pg +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL vcov( ip1jm,llm ),vcont( ip1jm,llm ), + * ucov( ip1jmp1,llm ),ucont( ip1jmp1,llm ),ecin( ip1jmp1,llm ) + + REAL ecinni( iip1 ),ecinsi( iip1 ) + + REAL ecinpn, ecinps + INTEGER l,ij,i + + REAL SSUM + + + +c . V +c i,j-1 + +c alpha4 . . alpha1 + + +c U . . P . U +c i-1,j i,j i,j + +c alpha3 . . alpha2 + + +c . V +c i,j + +c +c L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est : +c Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 ) + +c 0.5 * U(i ,j)**2 *( alpha1 + alpha2 ) + +c 0.5 * V(i,j-1)**2 *( alpha1 + alpha4 ) + +c 0.5 * V(i, j)**2 *( alpha2 + alpha3 ) + + + DO 5 l = 1,llm + + DO 1 ij = iip2, ip1jm -1 + ecin( ij+1, l ) = 0.5 * + * ( ucov( ij ,l ) * ucont( ij ,l ) * alpha3p4( ij +1 ) + + * ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 ) + + * vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 ) + + * vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 ) ) + 1 CONTINUE + +c ... correction pour ecin(1,j,l) .... +c ... ecin(1,j,l)= ecin(iip1,j,l) ... + +CDIR$ IVDEP + DO 2 ij = iip2, ip1jm, iip1 + ecin( ij,l ) = ecin( ij + iim, l ) + 2 CONTINUE + +c calcul aux poles ....... + + + DO 3 i = 1, iim + ecinni(i) = vcov( i , l) * vcont( i ,l) * aire( i ) + ecinsi(i) = vcov(i+ip1jmi1,l) * vcont(i+ip1jmi1,l) * aire(i+ip1jm) + 3 CONTINUE + + ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln + ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols + + DO 4 ij = 1,iip1 + ecin( ij , l ) = ecinpn + ecin( ij+ ip1jm, l ) = ecinps + 4 CONTINUE + + 5 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/enercin_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/enercin_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/enercin_loc.F (revision 1632) @@ -0,0 +1,122 @@ + SUBROUTINE enercin_loc ( vcov, ucov, vcont, ucont, ecin ) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .. calcul de l'energie cinetique aux niveaux s ...... +c ********************************************************************* +c vcov, vcont, ucov et ucont sont des arguments d'entree pour le s-pg . +c ecin est un argument de sortie pour le s-pg +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL vcov( ijb_v:ije_v,llm ),vcont( ijb_v:ije_v,llm ) + REAL ucov( ijb_u:ije_u,llm ),ucont( ijb_u:ije_u,llm ) + REAL ecin( ijb_u:ije_u,llm ) + + REAL ecinni( iip1 ),ecinsi( iip1 ) + + REAL ecinpn, ecinps + INTEGER l,ij,i,ijb,ije + + EXTERNAL SSUM + REAL SSUM + + + +c . V +c i,j-1 + +c alpha4 . . alpha1 + + +c U . . P . U +c i-1,j i,j i,j + +c alpha3 . . alpha2 + + +c . V +c i,j + +c +c L'energie cinetique au point scalaire P(i,j) ,autre que les poles, est : +c Ecin = 0.5 * U(i-1,j)**2 *( alpha3 + alpha4 ) + +c 0.5 * U(i ,j)**2 *( alpha1 + alpha2 ) + +c 0.5 * V(i,j-1)**2 *( alpha1 + alpha4 ) + +c 0.5 * V(i, j)**2 *( alpha2 + alpha3 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + ijb=ij_begin + ije=ij_end+iip1 + + IF (pole_nord) ijb=ij_begin+iip1 + IF (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb, ije -1 + ecin( ij+1, l ) = 0.5 * + * ( ucov( ij ,l ) * ucont( ij ,l ) * alpha3p4( ij +1 ) + + * ucov( ij+1 ,l ) * ucont( ij+1 ,l ) * alpha1p2( ij +1 ) + + * vcov(ij-iim,l ) * vcont(ij-iim,l ) * alpha1p4( ij +1 ) + + * vcov( ij+ 1,l ) * vcont( ij+ 1,l ) * alpha2p3( ij +1 ) ) + 1 CONTINUE + +c ... correction pour ecin(1,j,l) .... +c ... ecin(1,j,l)= ecin(iip1,j,l) ... + +CDIR$ IVDEP + DO 2 ij = ijb, ije, iip1 + ecin( ij,l ) = ecin( ij + iim, l ) + 2 CONTINUE + +c calcul aux poles ....... + + IF (pole_nord) THEN + + DO i = 1, iim + ecinni(i) = vcov( i , l) * + * vcont( i ,l) * aire( i ) + ENDDO + + ecinpn = 0.5 * SSUM( iim,ecinni,1 ) / apoln + + DO ij = 1,iip1 + ecin( ij , l ) = ecinpn + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO i = 1, iim + ecinsi(i) = vcov(i+ip1jmi1,l)* + * vcont(i+ip1jmi1,l) * aire(i+ip1jm) + ENDDO + + ecinps = 0.5 * SSUM( iim,ecinsi,1 ) / apols + + DO ij = 1,iip1 + ecin( ij+ ip1jm, l ) = ecinps + ENDDO + + ENDIF + + + 5 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/etat0_netcdf.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/etat0_netcdf.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/etat0_netcdf.F (revision 1632) @@ -0,0 +1,817 @@ +! +! $Id: etat0_netcdf.F 1379 2010-05-06 12:19:18Z lguez $ +! +c +c + SUBROUTINE etat0_netcdf (interbar, masque) +#ifdef CPP_EARTH + USE startvar + USE ioipsl + USE dimphy + USE control_mod + USE infotrac + USE fonte_neige_mod + USE pbl_surface_mod + USE phys_state_var_mod + USE filtreg_mod + use regr_lat_time_climoz_m, only: regr_lat_time_climoz + use conf_phys_m, only: conf_phys +! For parameterization of ozone chemistry: + use regr_lat_time_coefoz_m, only: regr_lat_time_coefoz + use press_coefoz_m, only: press_coefoz + use regr_pr_o3_m, only: regr_pr_o3 +#endif +!#endif of #ifdef CPP_EARTH + use netcdf, only: nf90_open, NF90_NOWRITE, nf90_close + ! + IMPLICIT NONE + ! +#include "dimensions.h" +#include "paramet.h" + ! + ! +! INTEGER, PARAMETER :: KIDIA=1, KFDIA=iim*(jjm-1)+2, +! .KLON=KFDIA-KIDIA+1,KLEV=llm + ! +#ifdef CPP_EARTH +#include "comgeom2.h" +#include "comvert.h" +#include "comconst.h" +#include "indicesol.h" +#include "dimsoil.h" +#include "temps.h" +#endif +!#endif of #ifdef CPP_EARTH + ! arguments: + LOGICAL interbar + REAL :: masque(iip1,jjp1) + +#ifdef CPP_EARTH + ! local variables: + REAL :: latfi(klon), lonfi(klon) + REAL :: orog(iip1,jjp1), rugo(iip1,jjp1) + REAL :: psol(iip1, jjp1), phis(iip1, jjp1) + REAL :: p3d(iip1, jjp1, llm+1) + REAL :: uvent(iip1, jjp1, llm) + REAL :: vvent(iip1, jjm, llm) + REAL :: t3d(iip1, jjp1, llm), tpot(iip1, jjp1, llm) + REAL :: qsat(iip1, jjp1, llm) + REAL,ALLOCATABLE :: q3d(:, :, :,:) + REAL :: tsol(klon), qsol(klon), sn(klon) +!! REAL :: tsolsrf(klon,nbsrf) + real qsolsrf(klon,nbsrf),snsrf(klon,nbsrf) + REAL :: albe(klon,nbsrf), evap(klon,nbsrf) + REAL :: alblw(klon,nbsrf) + REAL :: tsoil(klon,nsoilmx,nbsrf) + REAL :: frugs(klon,nbsrf), agesno(klon,nbsrf) + REAL :: rugmer(klon) + REAL :: qd(iip1, jjp1, llm) + REAL :: run_off_lic_0(klon) + ! declarations pour lecture glace de mer + REAL :: rugv(klon) + INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret + INTEGER :: itaul(1), fid + REAL :: lev(1), date + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_lic, dlat_lic + REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic + REAL :: flic_tmp(iip1, jjp1) + REAL :: champint(iim, jjp1) + ! + + CHARACTER(len=80) :: varname + ! + INTEGER :: i,j, ig, l, ji,ii1,ii2 + REAL :: xpi + ! + REAL :: alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm) + REAL :: pk(iip1,jjp1,llm), pls(iip1,jjp1,llm), pks(ip1jmp1) + REAL :: workvar(iip1,jjp1,llm) + ! + REAL :: prefkap, unskap + ! + real :: time_step,t_ops,t_wrt + +#include "comdissnew.h" +#include "serre.h" +#include "clesphys.h" + + INTEGER :: longcles + PARAMETER ( longcles = 20 ) + REAL :: clesphy0 ( longcles ) + REAL :: p(iip1,jjp1,llm) + INTEGER :: itau, iday + REAL :: masse(iip1,jjp1,llm) + REAL :: xpn,xps,xppn(iim),xpps(iim) + real :: time + REAL :: phi(ip1jmp1,llm) + REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) + REAL :: w(ip1jmp1,llm) + REAL ::phystep +CC REAL :: rugsrel(iip1*jjp1) + REAL :: fder(klon) +!! real zrel(iip1*jjp1),chmin,chmax + +!! CHARACTER(len=80) :: visu_file + INTEGER :: visuid + +! pour la lecture du fichier masque ocean + integer :: nid_o2a + logical :: couple = .false. + INTEGER :: iml_omask, jml_omask + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_omask, dlat_omask + REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp + real, dimension(klon) :: ocemask_fi + integer :: isst(klon-2) + real zx_tmp_2d(iim,jjp1) + + REAL :: dummy + + logical :: ok_newmicro + integer :: iflag_radia + logical :: ok_journe, ok_mensuel, ok_instan, ok_hf + logical :: ok_LES + LOGICAL :: ok_ade, ok_aie, aerosol_couple, new_aod + INTEGER :: flag_aerosol + REAL :: bl95_b0, bl95_b1 + real :: fact_cldcon, facttemps,ratqsbas,ratqshaut + real :: tau_ratqs + integer :: iflag_cldcon + integer :: iflag_ratqs + integer :: iflag_coupl + integer :: iflag_clos + integer :: iflag_wake + integer :: iflag_thermals,nsplit_thermals + real :: tau_thermals + integer :: iflag_thermals_ed,iflag_thermals_optflux + REAL :: solarlong0 + real :: seuil_inversion + real :: alp_offset + logical found + + integer read_climoz ! read ozone climatology +C Allowed values are 0, 1 and 2 +C 0: do not read an ozone climatology +C 1: read a single ozone climatology that will be used day and night +C 2: read two ozone climatologies, the average day and night +C climatology and the daylight climatology + + ! + ! Constantes + ! + pi = 4. * ATAN(1.) + rad = 6371229. + omeg = 4.* ASIN(1.)/(24.*3600.) + g = 9.8 + daysec = 86400. + kappa = 0.2857143 + cpp = 1004.70885 + ! + preff = 101325. + pa = 50000. + unskap = 1./kappa + ! + jmp1 = jjm + 1 + ! + ! Construct a grid + ! + +! CALL defrun_new(99,.TRUE.,clesphy0) + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + call conf_phys( ok_journe, ok_mensuel, ok_instan, ok_hf, ok_LES, & + & solarlong0,seuil_inversion, & + & fact_cldcon, facttemps,ok_newmicro,iflag_radia, & + & iflag_cldcon, & + & iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & + & ok_ade, ok_aie, aerosol_couple, & + & flag_aerosol, new_aod, & + & bl95_b0, bl95_b1, & + & iflag_thermals,nsplit_thermals,tau_thermals, & + & iflag_thermals_ed,iflag_thermals_optflux, & + & iflag_coupl,iflag_clos,iflag_wake, read_climoz, & + & alp_offset) + +! co2_ppm0 : initial value of atmospheric CO2 from .def file (co2_ppm value) + co2_ppm0 = co2_ppm + + dtvr = daysec/REAL(day_step) + print*,'dtvr',dtvr + + CALL iniconst() + CALL inigeom() + +! Initialisation pour traceurs + call infotrac_init + ALLOCATE(q3d(iip1, jjp1, llm, nqtot)) + + CALL inifilr() + CALL phys_state_var_init(read_climoz) + ! + latfi(1) = ASIN(1.0) + DO j = 2, jjm + DO i = 1, iim + latfi((j-2)*iim+1+i)= rlatu(j) + ENDDO + ENDDO + latfi(klon) = - ASIN(1.0) + ! + lonfi(1) = 0.0 + DO j = 2, jjm + DO i = 1, iim + lonfi((j-2)*iim+1+i) = rlonv(i) + ENDDO + ENDDO + lonfi(klon) = 0.0 + ! + xpi = 2.0 * ASIN(1.0) + DO ig = 1, klon + latfi(ig) = latfi(ig) * 180.0 / xpi + lonfi(ig) = lonfi(ig) * 180.0 / xpi + ENDDO + ! + rlat(1) = ASIN(1.0) + DO j = 2, jjm + DO i = 1, iim + rlat((j-2)*iim+1+i)= rlatu(j) + ENDDO + ENDDO + rlat(klon) = - ASIN(1.0) + ! + rlon(1) = 0.0 + DO j = 2, jjm + DO i = 1, iim + rlon((j-2)*iim+1+i) = rlonv(i) + ENDDO + ENDDO + rlon(klon) = 0.0 + ! + xpi = 2.0 * ASIN(1.0) + DO ig = 1, klon + rlat(ig) = rlat(ig) * 180.0 / xpi + rlon(ig) = rlon(ig) * 180.0 / xpi + ENDDO + ! + + + +C +C En cas de simulation couplee, lecture du masque ocean issu du modele ocean +C utilise pour calculer les poids et pour assurer l'adequation entre les +C fractions d'ocean vu par l'atmosphere et l'ocean. Sinon, on cree le masque +C a partir du fichier relief +C + + write(*,*)'Essai de lecture masque ocean' + iret = nf90_open("o2a.nc", NF90_NOWRITE, nid_o2a) + if (iret .ne. 0) then + write(*,*)'ATTENTION!! pas de fichier o2a.nc trouve' + write(*,*)'Run force' + varname = 'masque' + masque(:,:) = 0.0 + CALL startget_phys2d(varname, iip1, jjp1, rlonv, rlatu, masque, + $ 0.0, jjm ,rlonu,rlatv , interbar ) + WRITE(*,*) 'MASQUE construit : Masque' + WRITE(*,'(97I1)') nINT(masque(:,:)) + call gr_dyn_fi(1, iip1, jjp1, klon, masque, zmasq) + WHERE (zmasq(1 : klon) .LT. EPSFRA) + zmasq(1 : klon) = 0. + END WHERE + WHERE (1. - zmasq(1 : klon) .LT. EPSFRA) + zmasq(1 : klon) = 1. + END WHERE + else + couple = .true. + iret = nf90_close(nid_o2a) + call flininfo("o2a.nc", iml_omask, jml_omask, llm_tmp, ttm_tmp + $ , nid_o2a) + if (iml_omask /= iim .or. jml_omask /= jjp1) then + write(*,*)'Dimensions non compatibles pour masque ocean' + write(*,*)'iim = ',iim,' iml_omask = ',iml_omask + write(*,*)'jjp1 = ',jjp1,' jml_omask = ',jml_omask + stop + endif + ALLOCATE(lat_omask(iml_omask, jml_omask), stat=iret) + ALLOCATE(lon_omask(iml_omask, jml_omask), stat=iret) + ALLOCATE(dlon_omask(iml_omask), stat=iret) + ALLOCATE(dlat_omask(jml_omask), stat=iret) + ALLOCATE(ocemask(iml_omask, jml_omask), stat=iret) + ALLOCATE(ocetmp(iml_omask, jml_omask), stat=iret) + CALL flinopen("o2a.nc", .FALSE., iml_omask, jml_omask, llm_tmp + $ , lon_omask, lat_omask, lev, ttm_tmp, itaul, date, dt, fid) + CALL flinget(fid, 'OceMask', iml_omask, jml_omask, llm_tmp, + $ ttm_tmp, 1, 1, ocetmp) + CALL flinclo(fid) + dlon_omask(1 : iml_omask) = lon_omask(1 : iml_omask, 1) + dlat_omask(1 : jml_omask) = lat_omask(1 , 1 : jml_omask) + ocemask = ocetmp + if (dlat_omask(1) < dlat_omask(jml_omask)) then + do j = 1, jml_omask + ocemask(:,j) = ocetmp(:,jml_omask-j+1) + enddo + endif +C +C passage masque ocean a la grille physique +C + write(*,*)'ocemask ' + write(*,'(96i1)')int(ocemask) + ocemask_fi(1) = ocemask(1,1) + do j = 2, jjm + do i = 1, iim + ocemask_fi((j-2)*iim + i + 1) = ocemask(i,j) + enddo + enddo + ocemask_fi(klon) = ocemask(1,jjp1) + zmasq = 1. - ocemask_fi + endif + + call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) + + varname = 'relief' + ! This line needs to be replaced by a call to restget to get the values in the restart file + orog(:,:) = 0.0 + CALL startget_phys2d(varname, iip1, jjp1, rlonv, rlatu, orog, + $ 0.0 , jjm ,rlonu,rlatv , interbar, masque ) + ! + WRITE(*,*) 'OUT OF GET VARIABLE : Relief' +! WRITE(*,'(49I1)') INT(orog(:,:)) + ! + varname = 'rugosite' + ! This line needs to be replaced by a call to restget to get the values in the restart file + rugo(:,:) = 0.0 + CALL startget_phys2d(varname, iip1, jjp1, rlonv, rlatu, rugo, + $ 0.0 , jjm, rlonu,rlatv , interbar ) + ! + WRITE(*,*) 'OUT OF GET VARIABLE : Rugosite' +! WRITE(*,'(49I1)') INT(rugo(:,:)*10) + ! +C +C on initialise les sous surfaces +C + pctsrf=0. +c + varname = 'psol' + psol(:,:) = 0.0 + CALL startget_phys2d(varname, iip1, jjp1, rlonv, rlatu, psol, + $ 0.0 , jjm ,rlonu,rlatv , interbar ) + ! + ! Compute here the pressure on the intermediate levels. One would expect that this is available in the GCM + ! anyway. + ! +! WRITE(*,*) 'PSOL :', psol(10,20) +! WRITE(*,*) ap(:), bp(:) + CALL pression(ip1jmp1, ap, bp, psol, p3d) +! WRITE(*,*) 'P3D :', p3d(10,20,:) + CALL exner_hyb(ip1jmp1, psol, p3d, alpha, beta, pks, pk, workvar) +! WRITE(*,*) 'PK:', pk(10,20,:) + ! + ! + ! + prefkap = preff ** kappa +! WRITE(*,*) 'unskap, cpp, preff :', unskap, cpp, preff + DO l = 1, llm + DO j=1,jjp1 + DO i =1, iip1 + pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap + ENDDO + ENDDO + ENDDO + ! +! WRITE(*,*) 'PLS :', pls(10,20,:) + ! + varname = 'surfgeo' + phis(:,:) = 0.0 + CALL startget_phys2d(varname, iip1, jjp1, rlonv, rlatu, phis, + $ 0.0 , jjm ,rlonu,rlatv, interbar ) + ! + varname = 'u' + uvent(:,:,:) = 0.0 + CALL startget_dyn(varname, rlonu, rlatu, pls, workvar, uvent, 0., + $ rlonv, rlatv, interbar ) + ! + varname = 'v' + vvent(:,:,:) = 0.0 + CALL startget_dyn(varname, rlonv, rlatv, pls(:, :jjm, :), + . workvar(:, :jjm, :), vvent, 0., rlonu, rlatu(:jjm), interbar ) + ! + varname = 't' + t3d(:,:,:) = 0.0 + CALL startget_dyn(varname, rlonv, rlatu, pls, workvar, t3d, 0., + $ rlonu, rlatv , interbar ) + ! + WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)), + . maxval(t3d(:,:,:)) + varname = 'tpot' + tpot(:,:,:) = 0.0 + CALL startget_dyn(varname, rlonv, rlatu, pls, pk, tpot, 0., rlonu, + $ rlatv, interbar) + ! + WRITE(*,*) 'T3D min,max:',minval(t3d(:,:,:)), + . maxval(t3d(:,:,:)) + WRITE(*,*) 'PLS min,max:',minval(pls(:,:,:)), + . maxval(pls(:,:,:)) + +c Calcul de l'humidite a saturation + print*,'avant q_sat' + call q_sat(llm*jjp1*iip1,t3d,pls,qsat) + print*,'apres q_sat' + + WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)), + . maxval(qsat(:,:,:)) + ! +CC WRITE(*,*) 'QSAT :', qsat(10,20,:) + ! + varname = 'q' + qd(:,:,:) = 0.0 + q3d(:,:,:,:) = 0.0 + WRITE(*,*) 'QSAT min,max:',minval(qsat(:,:,:)), + . maxval(qsat(:,:,:)) + CALL startget_dyn(varname, rlonv, rlatu, pls, qsat, qd, 0., rlonu, + $ rlatv , interbar ) + q3d(:,:,:,1) = qd(:,:,:) + ! +! Parameterization of ozone chemistry: +C Look for ozone tracer: + i = 1 + DO + found = tname(i)=="O3" .OR. tname(i)=="o3" + if (found .or. i == nqtot) exit + i = i + 1 + end do + if (found) then + call regr_lat_time_coefoz + call press_coefoz + call regr_pr_o3(p3d, q3d(:, :, :, i)) +C Convert from mole fraction to mass fraction: + q3d(:, :, :, i) = q3d(:, :, :, i) * 48. / 29. + end if + +! Ozone climatology: + if (read_climoz >= 1) call regr_lat_time_climoz(read_climoz) + + varname = 'tsol' + ! This line needs to be replaced by a call to restget to get the values in the restart file + tsol(:) = 0.0 + CALL startget_phys1d(varname, iip1, jjp1, rlonv, rlatu, klon, + $ tsol, 0.0, jjm, rlonu, rlatv , interbar ) + ! + WRITE(*,*) 'TSOL construit :' +! WRITE(*,'(48I3)') INT(TSOL(2:klon)-273) + ! + varname = 'qsol' + qsol(:) = 0.0 + CALL startget_phys1d(varname, iip1, jjp1, rlonv, rlatu, klon, + $ qsol, 0.0, jjm, rlonu, rlatv , interbar ) + ! + varname = 'snow' + sn(:) = 0.0 + CALL startget_phys1d(varname, iip1, jjp1, rlonv, rlatu, klon, sn, + $ 0.0, jjm, rlonu, rlatv , interbar ) + ! + varname = 'rads' + radsol(:) = 0.0 + CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,radsol, + $ 0.0, jjm, rlonu, rlatv , interbar ) + ! + varname = 'rugmer' + rugmer(:) = 0.0 + CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,rugmer, + $ 0.0, jjm, rlonu, rlatv , interbar ) + ! +! varname = 'agesno' +! agesno(:) = 0.0 +! CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,agesno,0.0, +! . jjm, rlonu, rlatv , interbar ) + + varname = 'zmea' + zmea(:) = 0.0 + CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zmea,0.0, + . jjm, rlonu, rlatv , interbar ) + + varname = 'zstd' + zstd(:) = 0.0 + CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zstd,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zsig' + zsig(:) = 0.0 + CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zsig,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zgam' + zgam(:) = 0.0 + CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zgam,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zthe' + zthe(:) = 0.0 + CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zthe,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zpic' + zpic(:) = 0.0 + CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zpic,0.0, + . jjm, rlonu, rlatv , interbar ) + varname = 'zval' + zval(:) = 0.0 + CALL startget_phys1d(varname,iip1,jjp1,rlonv,rlatu,klon,zval,0.0, + . jjm, rlonu, rlatv , interbar ) +c +cc rugsrel(:) = 0.0 +cc IF(ok_orodr) THEN +cc DO i = 1, iip1* jjp1 +cc rugsrel(i) = MAX( 1.e-05, zstd(i)* zsig(i) /2. ) +cc ENDDO +cc ENDIF + + +C +C lecture du fichier glace de terre pour fixer la fraction de terre +C et de glace de terre +C + CALL flininfo("landiceref.nc", iml_lic, jml_lic,llm_tmp, ttm_tmp + $ , fid) + ALLOCATE(lat_lic(iml_lic, jml_lic), stat=iret) + ALLOCATE(lon_lic(iml_lic, jml_lic), stat=iret) + ALLOCATE(dlon_lic(iml_lic), stat=iret) + ALLOCATE(dlat_lic(jml_lic), stat=iret) + ALLOCATE(fraclic(iml_lic, jml_lic), stat=iret) + CALL flinopen("landiceref.nc", .FALSE., iml_lic, jml_lic, llm_tmp + $ , lon_lic, lat_lic, lev, ttm_tmp, itaul, date, dt, fid) + CALL flinget(fid, 'landice', iml_lic, jml_lic, llm_tmp, ttm_tmp + $ , 1, 1, fraclic) + CALL flinclo(fid) +C +C interpolation sur la grille T du modele +C + WRITE(*,*) 'dimensions de landice iml_lic, jml_lic : ', + $ iml_lic, jml_lic +c +C sil les coordonnees sont en degres, on les transforme +C + IF( MAXVAL( lon_lic(:,:) ) .GT. 2.0 * asin(1.0) ) THEN + lon_lic(:,:) = lon_lic(:,:) * 2.0* ASIN(1.0) / 180. + ENDIF + IF( maxval( lat_lic(:,:) ) .GT. 2.0 * asin(1.0)) THEN + lat_lic(:,:) = lat_lic(:,:) * 2.0 * asin(1.0) / 180. + ENDIF + + dlon_lic(1 : iml_lic) = lon_lic(1 : iml_lic, 1) + dlat_lic(1 : jml_lic) = lat_lic(1 , 1 : jml_lic) +C + CALL grille_m(iml_lic, jml_lic, dlon_lic, dlat_lic, fraclic + $ ,iim, jjp1, + $ rlonv, rlatu, flic_tmp(1 : iim, 1 : jjp1)) +cx$$$ flic_tmp(1 : iim, 1 : jjp1) = champint(1: iim, 1 : jjp1) + flic_tmp(iip1, 1 : jjp1) = flic_tmp(1 , 1 : jjp1) +C +C passage sur la grille physique +C + CALL gr_dyn_fi(1, iip1, jjp1, klon, flic_tmp, + $ pctsrf(1:klon, is_lic)) +C adequation avec le maque terre/mer +c zmasq(157) = 0. + WHERE (pctsrf(1 : klon, is_lic) .LT. EPSFRA ) + pctsrf(1 : klon, is_lic) = 0. + END WHERE + WHERE (zmasq( 1 : klon) .LT. EPSFRA) + pctsrf(1 : klon, is_lic) = 0. + END WHERE + pctsrf(1 : klon, is_ter) = zmasq(1 : klon) + DO ji = 1, klon + IF (zmasq(ji) .GT. EPSFRA) THEN + IF ( pctsrf(ji, is_lic) .GE. zmasq(ji)) THEN + pctsrf(ji, is_lic) = zmasq(ji) + pctsrf(ji, is_ter) = 0. + ELSE + pctsrf(ji,is_ter) = zmasq(ji) - pctsrf(ji, is_lic) + IF (pctsrf(ji,is_ter) .LT. EPSFRA) THEN + pctsrf(ji,is_ter) = 0. + pctsrf(ji, is_lic) = zmasq(ji) + ENDIF + ENDIF + ENDIF + END DO +C +C sous surface ocean et glace de mer (pour demarrer on met glace de mer a 0) +C + pctsrf(1 : klon, is_oce) = (1. - zmasq(1 : klon)) + + + WHERE (pctsrf(1 : klon, is_oce) .LT. EPSFRA) + pctsrf(1 : klon, is_oce) = 0. + END WHERE + + if (couple) pctsrf(1 : klon, is_oce) = ocemask_fi(1 : klon) + + isst = 0 + where (pctsrf(2:klon-1,is_oce) >0.) isst = 1 +C +C verif que somme des sous surface = 1 +C + ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf),dim=2))-1.0) + $ .GT. EPSFRA) + IF (ji .NE. 0) THEN + WRITE(*,*) 'pb repartition sous maille pour ',ji,' points' + ENDIF + +! where (pctsrf(1:klon, is_ter) >= .5) +! pctsrf(1:klon, is_ter) = 1. +! pctsrf(1:klon, is_oce) = 0. +! pctsrf(1:klon, is_sic) = 0. +! pctsrf(1:klon, is_lic) = 0. +! zmasq = 1. +! endwhere +! where (pctsrf(1:klon, is_lic) >= .5) +! pctsrf(1:klon, is_ter) = 0. +! pctsrf(1:klon, is_oce) = 0. +! pctsrf(1:klon, is_sic) = 0. +! pctsrf(1:klon, is_lic) = 1. +! zmasq = 1. +! endwhere +! where (pctsrf(1:klon, is_oce) >= .5) +! pctsrf(1:klon, is_ter) = 0. +! pctsrf(1:klon, is_oce) = 1. +! pctsrf(1:klon, is_sic) = 0. +! pctsrf(1:klon, is_lic) = 0. +! zmasq = 0. +! endwhere +! where (pctsrf(1:klon, is_sic) >= .5) +! pctsrf(1:klon, is_ter) = 0. +! pctsrf(1:klon, is_oce) = 0. +! pctsrf(1:klon, is_sic) = 1. +! pctsrf(1:klon, is_lic) = 0. +! zmasq = 0. +! endwhere +! call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) +C +C verif que somme des sous surface = 1 +C +! ji=count( (abs( sum(pctsrf(1 : klon, 1 : nbsrf), dim = 2)) - 1.0 ) +! $ .GT. EPSFRA) +! IF (ji .NE. 0) THEN +! WRITE(*,*) 'pb repartition sous maille pour ',ji,' points' +! ENDIF + + CALL gr_fi_ecrit(1,klon,iim,jjp1,zmasq,zx_tmp_2d) + write(*,*)'zmasq = ' + write(*,'(96i1)')nint(zx_tmp_2d) + call gr_fi_dyn(1, klon, iip1, jjp1, zmasq, masque) + WRITE(*,*) 'MASQUE construit : Masque' + WRITE(*,'(97I1)') nINT(masque(:,:)) + + + +C Calcul intermediaire +c + CALL massdair( p3d, masse ) +c + + print *,' ALPHAX ',alphax + + DO l = 1, llm + DO i = 1, iim + xppn(i) = aire( i, 1 ) * masse( i , 1 , l ) + xpps(i) = aire( i,jjp1 ) * masse( i , jjp1 , l ) + ENDDO + xpn = SUM(xppn)/apoln + xps = SUM(xpps)/apols + DO i = 1, iip1 + masse( i , 1 , l ) = xpn + masse( i , jjp1 , l ) = xps + ENDDO + ENDDO + q3d(iip1,:,:,:) = q3d(1,:,:,:) + phis(iip1,:) = phis(1,:) + +C Ecriture + CALL inidissip( lstardis, nitergdiv, nitergrot, niterh , + * tetagdiv, tetagrot , tetatemp ) + print*,'sortie inidissip' + itau = 0 + itau_dyn = 0 + itau_phy = 0 + iday = dayref +itau/day_step + time = real(itau-(iday-dayref)*day_step)/day_step +c + IF(time.GT.1) THEN + time = time - 1 + iday = iday + 1 + ENDIF + day_ref = dayref + annee_ref = anneeref + + CALL geopot ( ip1jmp1, tpot , pk , pks, phis , phi ) + print*,'sortie geopot' + + CALL caldyn0 ( itau,uvent,vvent,tpot,psol,masse,pk,phis , + * phi,w, pbaru,pbarv,time+iday-dayref ) + print*,'sortie caldyn0' + CALL dynredem0("start.nc",dayref,phis) + print*,'sortie dynredem0' + CALL dynredem1("start.nc",0.0,vvent,uvent,tpot,q3d,masse , + . psol) + print*,'sortie dynredem1' +C +C Ecriture etat initial physique +C + write(*,*)'phystep ',dtvr,iphysiq,nbapp_rad + phystep = dtvr * REAL(iphysiq) + radpas = NINT (86400./phystep/ REAL(nbapp_rad) ) + write(*,*)'phystep =', phystep, radpas +cIM : lecture de co2_ppm & solaire ds physiq.def +c co2_ppm = 348.0 +c solaire = 1365.0 + +c +c Initialisation +c tsol, qsol, sn,albe, evap,tsoil,rain_fall, snow_fall,solsw, sollw,frugs +c + ftsol(:,is_ter) = tsol + ftsol(:,is_lic) = tsol + ftsol(:,is_oce) = tsol + ftsol(:,is_sic) = tsol + snsrf(:,is_ter) = sn + snsrf(:,is_lic) = sn + snsrf(:,is_oce) = sn + snsrf(:,is_sic) = sn + falb1(:,is_ter) = 0.08 + falb1(:,is_lic) = 0.6 + falb1(:,is_oce) = 0.5 + falb1(:,is_sic) = 0.6 + falb2 = falb1 + evap(:,:) = 0. + qsolsrf(:,is_ter) = 150 + qsolsrf(:,is_lic) = 150 + qsolsrf(:,is_oce) = 150. + qsolsrf(:,is_sic) = 150. + do i = 1, nbsrf + do j = 1, nsoilmx + tsoil(:,j,i) = tsol + enddo + enddo + rain_fall = 0.; snow_fall = 0. + solsw = 165. + sollw = -53. + t_ancien = 273.15 + q_ancien = 0. + agesno = 0. +c + frugs(1:klon,is_oce) = rugmer(1:klon) + frugs(1:klon,is_ter) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0) + frugs(1:klon,is_lic) = MAX(1.0e-05, zstd(1:klon)*zsig(1:klon)/2.0) + frugs(1:klon,is_sic) = 0.001 + fder = 0.0 + clwcon = 0.0 + rnebcon = 0.0 + ratqs = 0.0 + run_off_lic_0 = 0.0 + rugoro = 0.0 + +c +c Avant l'appel a phyredem, on initialize les modules de surface +c avec les valeurs qui vont etre ecrit dans startphy.nc +c + dummy = 1.0 + pbl_tke(:,:,:) = 1.e-8 + zmax0(:) = 40. + f0(:) = 1.e-5 + ema_work1(:,:) = 0. + ema_work2(:,:) = 0. + wake_deltat(:,:) = 0. + wake_deltaq(:,:) = 0. + wake_s(:) = 0. + wake_cstar(:) = 0. + wake_fip(:) = 0. + wake_pe = 0. + fm_therm = 0. + entr_therm = 0. + detr_therm = 0. + + call fonte_neige_init(run_off_lic_0) + call pbl_surface_init(qsol, fder, snsrf, qsolsrf, + $ evap, frugs, agesno, tsoil) + + call phyredem("startphy.nc") + + + +C Sortie Visu pour les champs dynamiques +cc if (1.eq.0 ) then +cc print*,'sortie visu' +cc time_step = 1. +cc t_ops = 2. +cc t_wrt = 2. +cc itau = 2. +cc visu_file='Etat0_visu.nc' +cc CALL initdynav(visu_file,dayref,anneeref,time_step, +cc . t_ops, t_wrt, visuid) +cc CALL writedynav(visuid, itau,vvent , +cc . uvent,tpot,pk,phi,q3d,masse,psol,phis) +cc else + print*,'CCCCCCCCCCCCCCCCCC REACTIVER SORTIE VISU DANS ETAT0' +cc endif + print*,'entree histclo' + CALL histclo + +#endif +!#endif of #ifdef CPP_EARTH + RETURN + ! + END SUBROUTINE etat0_netcdf Index: /LMDZ5/trunk/libf/dyn3dmem/exner_hyb.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/exner_hyb.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/exner_hyb.F (revision 1632) @@ -0,0 +1,114 @@ +! +! $Header$ +! + 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 + + 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/dyn3dmem/exner_hyb_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/exner_hyb_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/exner_hyb_loc.F (revision 1632) @@ -0,0 +1,164 @@ + SUBROUTINE exner_hyb_loc(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 + USE parallel + USE mod_filtreg_p + USE write_field_loc + 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(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm) + REAL pkf(ijb_u:ije_u,llm) + REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u) + REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL unpl2k,dellta + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM + EXTERNAL SSUM + INTEGER ije,ijb,jje,jjb +c +c$OMP BARRIER + unpl2k = 1.+ 2.* kappa +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO +c$OMP ENDDO +c Synchro OPENMP ici + +c$OMP MASTER + if (pole_nord) then + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + + DO ij = 1, iip1 + pks( ij ) = xpn + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iim + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij+ip1jm ) = xps + ENDDO + endif +c$OMP END MASTER +c$OMP BARRIER +c +c +c .... Calcul des coeff. alpha et beta pour la couche l = llm .. +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb,ije + alpha(ij,llm) = 0. + beta (ij,llm) = 1./ unpl2k + ENDDO +c$OMP ENDDO NOWAIT +c +c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... +c + DO l = llm -1 , 2 , -1 +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + 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$OMP ENDDO NOWAIT +c + ENDDO + +c +c *********************************************************************** +c ..... Calcul de pk pour la couche 1 , pres du sol .... +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + 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$OMP ENDDO NOWAIT +c +c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ +c + DO l = 2, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO +c +c +c CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + DO l = 1, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pkf(ij,l)=pk(ij,l) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + +c$OMP BARRIER + + jjb=jj_begin + jje=jj_end +#ifdef DEBUG_IO + call WriteField_u('pkf',pkf) +#endif + CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, + & 2, 1, .TRUE., 1 ) +#ifdef DEBUG_IO + call WriteField_u('pkf',pkf) +#endif + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/exner_hyb_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/exner_hyb_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/exner_hyb_p.F (revision 1632) @@ -0,0 +1,153 @@ + SUBROUTINE exner_hyb_p ( 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 + USE parallel + 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 + EXTERNAL SSUM + INTEGER ije,ijb,jje,jjb +c +c$OMP BARRIER + unpl2k = 1.+ 2.* kappa +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO +c$OMP ENDDO +c Synchro OPENMP ici + +c$OMP MASTER + if (pole_nord) then + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + + DO ij = 1, iip1 + pks( ij ) = xpn + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iim + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij+ip1jm ) = xps + ENDDO + endif +c$OMP END MASTER +c +c +c .... Calcul des coeff. alpha et beta pour la couche l = llm .. +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb,ije + alpha(ij,llm) = 0. + beta (ij,llm) = 1./ unpl2k + ENDDO +c$OMP ENDDO NOWAIT +c +c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... +c + DO l = llm -1 , 2 , -1 +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + 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$OMP ENDDO NOWAIT +c + ENDDO + +c +c *********************************************************************** +c ..... Calcul de pk pour la couche 1 , pres du sol .... +c +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + 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$OMP ENDDO NOWAIT +c +c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ +c + DO l = 2, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO +c +c +c CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + DO l = 1, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pkf(ij,l)=pk(ij,l) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + +c$OMP BARRIER + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/exner_milieu_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/exner_milieu_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/exner_milieu_loc.F (revision 1632) @@ -0,0 +1,226 @@ +! +! $Id $ +! + SUBROUTINE exner_milieu_loc ( ngrid, ps, p,beta, pks, pk, pkf ) +c +c Auteurs : F. Forget , Y. Wanherdrick +c P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des +c couches . Pk(l) sera calcule aux milieux des couches l ,entre les +c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . +c ************************************************************************ +c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont +c la pression et la fonction d'Exner au sol . +c +c WARNING : CECI est une version speciale de exner_hyb originale +c Utilise dans la version martienne pour pouvoir +c tourner avec des coordonnees verticales complexe +c => Il ne verifie PAS la condition la proportionalite en +c energie totale/ interne / potentielle (F.Forget 2001) +c ( voir note de Fr.Hourdin ) , +c + USE parallel + 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(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm) + REAL pkf(ijb_u:ije_u,llm) + REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u) + REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL dum1 + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM + EXTERNAL SSUM + INTEGER ije,ijb,jje,jjb + logical,save :: firstcall=.true. +!$OMP THREADPRIVATE(firstcall) + character(len=*),parameter :: modname="exner_milieu_p" + + ! Sanity check + if (firstcall) then + ! check that vertical discretization is compatible + ! with this routine + if (disvert_type.ne.2) then + call abort_gcm(modname, + & "this routine should only be called if disvert_type==2",42) + endif + + ! 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) + +c$OMP BARRIER + +! Specific behaviour for Shallow Water (1 vertical layer) case + if (llm.eq.1) then + + ! Compute pks(:),pk(:),pkf(:) + ijb=ij_begin + ije=ij_end +!$OMP DO SCHEDULE(STATIC) + DO ij=ijb, ije + pks(ij)=(cpp/preff)*ps(ij) + pk(ij,1) = .5*pks(ij) + pkf(ij,1)=pk(ij,1) + ENDDO +!$OMP ENDDO + +!$OMP MASTER + if (pole_nord) then + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + + DO ij = 1, iip1 + pks( ij ) = xpn + pk(ij,1) = .5*pks(ij) + pkf(ij,1)=pk(ij,1) + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iim + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij+ip1jm ) = xps + pk(ij+ip1jm,1)=.5*pks(ij+ip1jm) + pkf(ij+ip1jm,1)=pk(ij+ip1jm,1) + ENDDO + endif +!$OMP END MASTER + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) + + ! our work is done, exit routine + return + endif ! of if (llm.eq.1) + +!!!! General case: + +c ------------- +c Calcul de pks +c ------------- + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO +c$OMP ENDDO +c Synchro OPENMP ici + +c$OMP MASTER + if (pole_nord) then + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + + DO ij = 1, iip1 + pks( ij ) = xpn + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iim + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij+ip1jm ) = xps + ENDDO + endif +c$OMP END MASTER +c +c +c .... Calcul de pk pour la couche l +c -------------------------------------------- +c + dum1 = cpp * (2*preff)**(-kappa) + DO l = 1, llm-1 +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + +c .... Calcul de pk pour la couche l = llm .. +c (on met la meme distance (en log pression) entre Pk(llm) +c et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2) + ENDDO +c$OMP ENDDO NOWAIT + + +c calcul de pkf +c ------------- +c CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + DO l = 1, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pkf(ij,l)=pk(ij,l) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + +c$OMP BARRIER + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) + +c EST-CE UTILE ?? : calcul de beta +c -------------------------------- + DO l = 2, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + beta(ij,l) = pk(ij,l) / pk(ij,l-1) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/exner_milieu_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/exner_milieu_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/exner_milieu_p.F (revision 1632) @@ -0,0 +1,224 @@ +! +! $Id $ +! + SUBROUTINE exner_milieu_p ( ngrid, ps, p,beta, pks, pk, pkf ) +c +c Auteurs : F. Forget , Y. Wanherdrick +c P.Le Van , Fr. Hourdin . +c .......... +c +c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... +c .... beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... +c +c ************************************************************************ +c Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des +c couches . Pk(l) sera calcule aux milieux des couches l ,entre les +c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . +c ************************************************************************ +c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont +c la pression et la fonction d'Exner au sol . +c +c WARNING : CECI est une version speciale de exner_hyb originale +c Utilise dans la version martienne pour pouvoir +c tourner avec des coordonnees verticales complexe +c => Il ne verifie PAS la condition la proportionalite en +c energie totale/ interne / potentielle (F.Forget 2001) +c ( voir note de Fr.Hourdin ) , +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "serre.h" + + INTEGER ngrid + REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) + REAL ps(ngrid),pks(ngrid), beta(ngrid,llm) + +c .... variables locales ... + + INTEGER l, ij + REAL dum1 + + REAL ppn(iim),pps(iim) + REAL xpn, xps + REAL SSUM + EXTERNAL SSUM + INTEGER ije,ijb,jje,jjb + logical,save :: firstcall=.true. +!$OMP THREADPRIVATE(firstcall) + character(len=*),parameter :: modname="exner_milieu_p" + + ! Sanity check + if (firstcall) then + ! check that vertical discretization is compatible + ! with this routine + if (disvert_type.ne.2) then + call abort_gcm(modname, + & "this routine should only be called if disvert_type==2",42) + endif + + ! 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) + +c$OMP BARRIER + +! Specific behaviour for Shallow Water (1 vertical layer) case + if (llm.eq.1) then + + ! Compute pks(:),pk(:),pkf(:) + ijb=ij_begin + ije=ij_end +!$OMP DO SCHEDULE(STATIC) + DO ij=ijb, ije + pks(ij)=(cpp/preff)*ps(ij) + pk(ij,1) = .5*pks(ij) + pkf(ij,1)=pk(ij,1) + ENDDO +!$OMP ENDDO + +!$OMP MASTER + if (pole_nord) then + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + + DO ij = 1, iip1 + pks( ij ) = xpn + pk(ij,1) = .5*pks(ij) + pkf(ij,1)=pk(ij,1) + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iim + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij+ip1jm ) = xps + pk(ij+ip1jm,1)=.5*pks(ij+ip1jm) + pkf(ij+ip1jm,1)=pk(ij+ip1jm,1) + ENDDO + endif +!$OMP END MASTER + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) + + ! our work is done, exit routine + return + endif ! of if (llm.eq.1) + +!!!! General case: + +c ------------- +c Calcul de pks +c ------------- + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pks(ij) = cpp * ( ps(ij)/preff ) ** kappa + ENDDO +c$OMP ENDDO +c Synchro OPENMP ici + +c$OMP MASTER + if (pole_nord) then + DO ij = 1, iim + ppn(ij) = aire( ij ) * pks( ij ) + ENDDO + xpn = SSUM(iim,ppn,1) /apoln + + DO ij = 1, iip1 + pks( ij ) = xpn + ENDDO + endif + + if (pole_sud) then + DO ij = 1, iim + pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) + ENDDO + xps = SSUM(iim,pps,1) /apols + + DO ij = 1, iip1 + pks( ij+ip1jm ) = xps + ENDDO + endif +c$OMP END MASTER +c +c +c .... Calcul de pk pour la couche l +c -------------------------------------------- +c + dum1 = cpp * (2*preff)**(-kappa) + DO l = 1, llm-1 +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + +c .... Calcul de pk pour la couche l = llm .. +c (on met la meme distance (en log pression) entre Pk(llm) +c et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) + +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2) + ENDDO +c$OMP ENDDO NOWAIT + + +c calcul de pkf +c ------------- +c CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) + DO l = 1, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + pkf(ij,l)=pk(ij,l) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + +c$OMP BARRIER + + jjb=jj_begin + jje=jj_end + CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) + +c EST-CE UTILE ?? : calcul de beta +c -------------------------------- + DO l = 2, llm +c$OMP DO SCHEDULE(STATIC) + DO ij = ijb, ije + beta(ij,l) = pk(ij,l) / pk(ij,l-1) + ENDDO +c$OMP ENDDO NOWAIT + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/extrapol.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/extrapol.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/extrapol.F (revision 1632) @@ -0,0 +1,200 @@ +! +! $Id: extrapol.F 1299 2010-01-20 14:27:21Z fairhead $ +! +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/dyn3dmem/filtreg_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/filtreg_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/filtreg_p.F (revision 1632) @@ -0,0 +1,400 @@ + + + SUBROUTINE filtreg_p ( champ, ibeg, iend, nlat, nbniv, + & ifiltre, iaire, griscal ,iter) + USE Parallel, only : OMP_CHUNK + USE mod_filtre_fft + USE timer_filtre + + USE filtreg_mod + + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van 07/10/97 +c ------ +c +c Objet: filtre matriciel longitudinal ,avec les matrices precalculees +c pour l'operateur Filtre . +c ------ +c +c Arguments: +c ---------- +c +c +c ibeg..iend lattitude a filtrer +c nlat nombre de latitudes du champ +c nbniv nombre de niveaux verticaux a filtrer +c champ(iip1,nblat,nbniv) en entree : champ a filtrer +c en sortie : champ filtre +c ifiltre +1 Transformee directe +c -1 Transformee inverse +c +2 Filtre directe +c -2 Filtre inverse +c +c iaire 1 si champ intensif +c 2 si champ extensif (pondere par les aires) +c +c iter 1 filtre simple +c +c======================================================================= +c +c +c Variable Intensive +c ifiltre = 1 filtre directe +c ifiltre =-1 filtre inverse +c +c Variable Extensive +c ifiltre = 2 filtre directe +c ifiltre =-2 filtre inverse +c +c +#include "dimensions.h" +#include "paramet.h" +#include "coefils.h" +c + INTEGER ibeg,iend,nlat,nbniv,ifiltre,iter + INTEGER i,j,l,k + INTEGER iim2,immjm + INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil + + REAL champ( iip1,nlat,nbniv) + + LOGICAL griscal + INTEGER hemisph, iaire + + REAL :: champ_fft(iip1,nlat,nbniv) + REAL :: champ_in(iip1,nlat,nbniv) + + LOGICAL,SAVE :: first=.TRUE. +c$OMP THREADPRIVATE(first) + + REAL, DIMENSION(iip1,nlat,nbniv) :: champ_loc + INTEGER :: ll_nb, nbniv_loc + REAL, SAVE :: sdd12(iim,4) +c$OMP THREADPRIVATE(sdd12) + + INTEGER, PARAMETER :: type_sddu=1 + INTEGER, PARAMETER :: type_sddv=2 + INTEGER, PARAMETER :: type_unsddu=3 + INTEGER, PARAMETER :: type_unsddv=4 + + INTEGER :: sdd1_type, sdd2_type + + IF (first) THEN + sdd12(1:iim,type_sddu) = sddu(1:iim) + sdd12(1:iim,type_sddv) = sddv(1:iim) + sdd12(1:iim,type_unsddu) = unsddu(1:iim) + sdd12(1:iim,type_unsddv) = unsddv(1:iim) + + CALL Init_timer + first=.FALSE. + ENDIF + +c$OMP MASTER + CALL start_timer +c$OMP END MASTER + +c-------------------------------------------------------c + + IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) + & STOP'Pas de transformee simple dans cette version' + + IF( iter.EQ. 2 ) THEN + PRINT *,' Pas d iteration du filtre dans cette version !' + & , ' Utiliser old_filtreg et repasser !' + STOP + ENDIF + + IF( ifiltre.EQ. -2 .AND..NOT.griscal ) THEN + PRINT *,' Cette routine ne calcule le filtre inverse que ' + & , ' sur la grille des scalaires !' + STOP + ENDIF + + IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 ) THEN + PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' + & , ' corriger et repasser !' + STOP + ENDIF +c + + iim2 = iim * iim + immjm = iim * jjm +c +c + IF( griscal ) THEN + IF( nlat. NE. jjp1 ) THEN + PRINT 1111 + STOP + ELSE +c + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddv + sdd2_type = type_unsddv + ELSE + sdd1_type = type_unsddv + sdd2_type = type_sddv + ENDIF +c + jdfil1 = 2 + jffil1 = jfiltnu + jdfil2 = jfiltsu + jffil2 = jjm + ENDIF + ELSE + IF( nlat.NE.jjm ) THEN + PRINT 2222 + STOP + ELSE +c + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddu + sdd2_type = type_unsddu + ELSE + sdd1_type = type_unsddu + sdd2_type = type_sddu + ENDIF +c + jdfil1 = 1 + jffil1 = jfiltnv + jdfil2 = jfiltsv + jffil2 = jjm + ENDIF + ENDIF +c + DO hemisph = 1, 2 +c + IF ( hemisph.EQ.1 ) THEN +cym + jdfil = max(jdfil1,ibeg) + jffil = min(jffil1,iend) + ELSE +cym + jdfil = max(jdfil2,ibeg) + jffil = min(jffil2,iend) + ENDIF + + +cccccccccccccccccccccccccccccccccccccccccccc +c Utilisation du filtre classique +cccccccccccccccccccccccccccccccccccccccccccc + + IF (.NOT. use_filtre_fft) THEN + +c !---------------------------------! +c ! Agregation des niveau verticaux ! +c ! uniquement necessaire pour une ! +c ! execution OpenMP ! +c !---------------------------------! + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv + ll_nb = ll_nb+1 + DO j = jdfil,jffil + DO i = 1, iim + champ_loc(i,j,ll_nb) = + & champ(i,j,l) * sdd12(i,sdd1_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + nbniv_loc = ll_nb + + IF( hemisph.EQ.1 ) THEN + + IF( ifiltre.EQ.-2 ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matrinvn(1,1,j), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE IF ( griscal ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matriceun(1,1,j), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matricevn(1,1,j), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ENDIF + + ELSE + + IF( ifiltre.EQ.-2 ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matrinvs(1,1,j-jfiltsu+1), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE IF ( griscal ) THEN + + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matriceus(1,1,j-jfiltsu+1), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ELSE + + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matricevs(1,1,j-jfiltsv+1), iim, + & champ_loc(1,j,1), iip1*nlat, 0.0, + & champ_fft(1,j-jdfil+1,1), iip1*nlat) + ENDDO + + ENDIF + + ENDIF +! c + IF( ifiltre.EQ.2 ) THEN + +c !-------------------------------------! +c ! Dés-agregation des niveau verticaux ! +c ! uniquement necessaire pour une ! +c ! execution OpenMP ! +c !-------------------------------------! + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv + ll_nb = ll_nb + 1 + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = (champ_loc(i,j,ll_nb) + & + champ_fft(i,j-jdfil+1,ll_nb)) + & * sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ELSE + + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv_loc + ll_nb = ll_nb + 1 + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = (champ_loc(i,j,ll_nb) + & - champ_fft(i,j-jdfil+1,ll_nb)) + & * sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ENDIF + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv + DO j = jdfil,jffil + champ( iip1,j,l ) = champ( 1,j,l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +ccccccccccccccccccccccccccccccccccccccccccccc +c Utilisation du filtre FFT +ccccccccccccccccccccccccccccccccccccccccccccc + + ELSE + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type) + champ_fft( i,j,l) = champ(i,j,l) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + IF (jdfil<=jffil) THEN + IF( ifiltre. EQ. -2 ) THEN + CALL Filtre_inv_fft(champ_fft,nlat,jdfil,jffil,nbniv) + ELSE IF ( griscal ) THEN + CALL Filtre_u_fft(champ_fft,nlat,jdfil,jffil,nbniv) + ELSE + CALL Filtre_v_fft(champ_fft,nlat,jdfil,jffil,nbniv) + ENDIF + ENDIF + + + IF( ifiltre.EQ. 2 ) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l)) + & *sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + ELSE + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l)) + & *sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil +! champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l ) + champ( iip1,j,l ) = champ( 1,j,l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF +c Fin de la zone de filtrage + + + ENDDO + +! DO j=1,nlat +! +! PRINT *,"check FFT ----> Delta(",j,")=", +! & sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)), +! & sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:)) +! ENDDO + +! PRINT *,"check FFT ----> Delta(",j,")=", +! & sum(champ-champ_fft)/sum(champ) +! + +c + 1111 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a + & filtrer, sur la grille des scalaires'/) + 2222 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi + & ltrer, sur la grille de V ou de Z'/) +c$OMP MASTER + CALL stop_timer +c$OMP END MASTER + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/flumass.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/flumass.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/flumass.F (revision 1632) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE flumass (massebx,masseby, vcont, ucont, pbaru, pbarv ) + + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van, F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .... calcul du flux de masse aux niveaux s ...... +c ********************************************************************* +c massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg . +c pbaru et pbarv sont des argum.de sortie pour le s-pg . +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL massebx( ip1jmp1,llm ),masseby( ip1jm,llm ) , + * vcont( ip1jm,llm ),ucont( ip1jmp1,llm ),pbaru( ip1jmp1,llm ), + * pbarv( ip1jm,llm ) + + REAL apbarun( iip1 ),apbarus( iip1 ) + + REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0 + INTEGER l,ij,i + + REAL SSUM + + + DO 5 l = 1,llm + + DO 1 ij = iip2,ip1jm + pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l ) + 1 CONTINUE + + DO 3 ij = 1,ip1jm + pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l ) + 3 CONTINUE + + 5 CONTINUE + +c ................................................................ +c calcul de la composante du flux de masse en x aux poles ....... +c ................................................................ +c par la resolution d'1 systeme de 2 equations . + +c la premiere equat.decrivant le calcul de la divergence en 1 point i +c du pole,ce calcul etant itere de i=1 a i=im . +c c.a.d , +c ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i) = +c - somme de ( pbarv(n) )/aire pole + +c l'autre equat.specifiant que la moyenne du flux de masse au pole est =0. +c c.a.d somme de pbaru(n)*aire locale(n) = 0. + +c on en revient ainsi a determiner la constante additive commune aux pbaru +c qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt +c i=1 . +c i variant de 1 a im +c n variant de 1 a im + + sairen = SSUM( iim, aire( 1 ), 1 ) + saireun= SSUM( iim, aireu( 1 ), 1 ) + saires = SSUM( iim, aire( ip1jm+1 ), 1 ) + saireus= SSUM( iim, aireu( ip1jm+1 ), 1 ) + + DO 20 l = 1,llm + + ctn = SSUM( iim, pbarv( 1 ,l), 1 )/ sairen + cts = SSUM( iim, pbarv(ip1jmi1+ 1,l), 1 )/ saires + + pbaru( 1 ,l )= pbarv( 1 ,l ) - ctn * aire( 1 ) + pbaru( ip1jm+1,l )= - pbarv( ip1jmi1+1,l ) + cts * aire( ip1jm+1 ) + + DO 11 i = 2,iim + pbaru( i ,l ) = pbaru( i - 1 ,l ) + + * pbarv( i ,l ) - ctn * aire( i ) + + pbaru( i+ ip1jm,l ) = pbaru( i+ ip1jm-1,l ) - + * pbarv( i+ ip1jmi1,l ) + cts * aire(i+ ip1jm) + 11 CONTINUE + DO 12 i = 1,iim + apbarun(i) = aireu( i ) * pbaru( i , l) + apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l) + 12 CONTINUE + ctn0 = -SSUM( iim,apbarun,1 )/saireun + cts0 = -SSUM( iim,apbarus,1 )/saireus + DO 14 i = 1,iim + pbaru( i , l) = 2. * ( pbaru( i , l) + ctn0 ) + pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 ) + 14 CONTINUE + + pbaru( iip1 ,l ) = pbaru( 1 ,l ) + pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l ) + 20 CONTINUE + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/flumass_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/flumass_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/flumass_loc.F (revision 1632) @@ -0,0 +1,152 @@ + SUBROUTINE flumass_loc(massebx,masseby,vcont,ucont,pbaru,pbarv) + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van, F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ********************************************************************* +c .... calcul du flux de masse aux niveaux s ...... +c ********************************************************************* +c massebx,masseby,vcont et ucont sont des argum. d'entree pour le s-pg . +c pbaru et pbarv sont des argum.de sortie pour le s-pg . +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL massebx( ijb_u:ije_u,llm ),masseby( ijb_v:ije_v,llm ) , + * vcont( ijb_v:ije_v,llm ),ucont( ijb_u:ije_u,llm ), + * pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm ) + + REAL apbarun( iip1 ),apbarus( iip1 ) + + REAL sairen,saireun,saires,saireus,ctn,cts,ctn0,cts0 + INTEGER l,ij,i + INTEGER ijb,ije + + EXTERNAL SSUM + REAL SSUM + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + ijb=ij_begin + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb,ije + pbaru( ij,l ) = massebx( ij,l ) * ucont( ij,l ) + 1 CONTINUE + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO 3 ij = ijb,ije + pbarv( ij,l ) = masseby( ij,l ) * vcont( ij,l ) + 3 CONTINUE + + 5 CONTINUE +c$OMP END DO NOWAIT +c ................................................................ +c calcul de la composante du flux de masse en x aux poles ....... +c ................................................................ +c par la resolution d'1 systeme de 2 equations . + +c la premiere equat.decrivant le calcul de la divergence en 1 point i +c du pole,ce calcul etant itere de i=1 a i=im . +c c.a.d , +c ( ( 0.5*pbaru(i)-0.5*pbaru(i-1) - pbarv(i))/aire(i) = +c - somme de ( pbarv(n) )/aire pole + +c l'autre equat.specifiant que la moyenne du flux de masse au pole est =0. +c c.a.d somme de pbaru(n)*aire locale(n) = 0. + +c on en revient ainsi a determiner la constante additive commune aux pbaru +c qui representait pbaru(0,j,l) dans l'equat.du calcul de la diverg.au pt +c i=1 . +c i variant de 1 a im +c n variant de 1 a im + + IF (pole_nord) THEN + + sairen = SSUM( iim, aire( 1 ), 1 ) + saireun= SSUM( iim, aireu( 1 ), 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + + ctn = SSUM( iim, pbarv( 1 ,l), 1 )/ sairen + + pbaru(1,l)=pbarv(1,l) - ctn * aire(1) + + DO i = 2,iim + pbaru(i,l) = pbaru(i- 1,l ) + + * pbarv(i,l) - ctn * aire(i ) + ENDDO + + DO i = 1,iim + apbarun(i) = aireu( i ) * pbaru( i , l) + ENDDO + + ctn0 = -SSUM( iim,apbarun,1 )/saireun + + DO i = 1,iim + pbaru( i , l) = 2. * ( pbaru( i , l) + ctn0 ) + ENDDO + + pbaru( iip1 ,l ) = pbaru( 1 ,l ) + + ENDDO +c$OMP END DO NOWAIT + + ENDIF + + + IF (pole_sud) THEN + + saires = SSUM( iim, aire( ip1jm+1 ), 1 ) + saireus= SSUM( iim, aireu( ip1jm+1 ), 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + + cts = SSUM( iim, pbarv(ip1jmi1+ 1,l), 1 )/ saires + pbaru(ip1jm+1,l)= - pbarv(ip1jmi1+1,l) + cts * aire(ip1jm+1) + + DO i = 2,iim + pbaru(i+ ip1jm,l) = pbaru(i+ip1jm-1,l) - + * pbarv(i+ip1jmi1,l)+cts*aire(i+ip1jm) + ENDDO + + DO i = 1,iim + apbarus(i) = aireu(i +ip1jm) * pbaru(i +ip1jm, l) + ENDDO + + cts0 = -SSUM( iim,apbarus,1 )/saireus + + DO i = 1,iim + pbaru(i+ ip1jm, l) = 2. * ( pbaru(i +ip1jm, l) + cts0 ) + ENDDO + + pbaru( ip1jmp1,l ) = pbaru( ip1jm +1,l ) + + ENDDO +c$OMP END DO NOWAIT + ENDIF + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/friction_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/friction_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/friction_loc.F (revision 1632) @@ -0,0 +1,143 @@ +! +! $Id: friction_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c======================================================================= + SUBROUTINE friction_loc(ucov,vcov,pdt) + USE parallel + USE control_mod + IMPLICIT NONE + +c======================================================================= +c +c +c Objet: +c ------ +c +c *********** +c Friction +c *********** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comconst.h" + + REAL pdt + REAL modv(iip1,jjb_u:jje_u),zco,zsi + REAL vpn,vps,upoln,upols,vpols,vpoln + REAL u2(iip1,jjb_u:jje_u),v2(iip1,jjb_v:jje_v) + REAL ucov( iip1,jjb_u:jje_u,llm ),vcov( iip1,jjb_v:jje_v,llm ) + INTEGER i,j + REAL cfric + parameter (cfric=1.e-5) + integer :: jjb,jje + + +c calcul des composantes au carre du vent naturel + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + + do j=jjb,jje + do i=1,iip1 + u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j) + enddo + enddo + + jjb=jj_begin-1 + jje=jj_end+1 + if (pole_nord) jjb=jj_begin + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iip1 + v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j) + enddo + enddo + +c calcul du module de V en dehors des poles + jjb=jj_begin + jje=jj_end+1 + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=2,iip1 + modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j))) + enddo + modv(1,j)=modv(iip1,j) + enddo + +c les deux composantes du vent au pole sont obtenues comme +c premiers modes de fourier de v pres du pole + if (pole_nord) then + + upoln=0. + vpoln=0. + + do i=2,iip1 + zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) + zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) + vpn=vcov(i,1,1)/cv(i,1) + upoln=upoln+zco*vpn + vpoln=vpoln+zsi*vpn + enddo + vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi + do i=1,iip1 +c modv(i,1)=vpn + modv(i,1)=modv(i,2) + enddo + + endif + + if (pole_sud) then + + upols=0. + vpols=0. + do i=2,iip1 + zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) + zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) + vps=vcov(i,jjm,1)/cv(i,jjm) + upols=upols+zco*vps + vpols=vpols+zsi*vps + enddo + vps=sqrt(upols*upols+vpols*vpols)/pi + do i=1,iip1 +c modv(i,jjp1)=vps + modv(i,jjp1)=modv(i,jjm) + enddo + + endif + +c calcul du frottement au sol. + + jjb=jj_begin + jje=jj_end + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iim + ucov(i,j,1)=ucov(i,j,1) + s -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1) + enddo + ucov(iip1,j,1)=ucov(1,j,1) + enddo + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iip1 + vcov(i,j,1)=vcov(i,j,1) + s -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1) + enddo + vcov(iip1,j,1)=vcov(1,j,1) + enddo + + RETURN + END + Index: /LMDZ5/trunk/libf/dyn3dmem/friction_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/friction_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/friction_p.F (revision 1632) @@ -0,0 +1,143 @@ +! +! $Id: friction_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c======================================================================= + SUBROUTINE friction_p(ucov,vcov,pdt) + USE parallel + USE control_mod + IMPLICIT NONE + +c======================================================================= +c +c +c Objet: +c ------ +c +c *********** +c Friction +c *********** +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comconst.h" + + REAL pdt + REAL modv(iip1,jjp1),zco,zsi + REAL vpn,vps,upoln,upols,vpols,vpoln + REAL u2(iip1,jjp1),v2(iip1,jjm) + REAL ucov( iip1,jjp1,llm ),vcov( iip1,jjm,llm ) + INTEGER i,j + REAL cfric + parameter (cfric=1.e-5) + integer :: jjb,jje + + +c calcul des composantes au carre du vent naturel + jjb=jj_begin + jje=jj_end+1 + if (pole_sud) jje=jj_end + + do j=jjb,jje + do i=1,iip1 + u2(i,j)=ucov(i,j,1)*ucov(i,j,1)*unscu2(i,j) + enddo + enddo + + jjb=jj_begin-1 + jje=jj_end+1 + if (pole_nord) jjb=jj_begin + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iip1 + v2(i,j)=vcov(i,j,1)*vcov(i,j,1)*unscv2(i,j) + enddo + enddo + +c calcul du module de V en dehors des poles + jjb=jj_begin + jje=jj_end+1 + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=2,iip1 + modv(i,j)=sqrt(0.5*(u2(i-1,j)+u2(i,j)+v2(i,j-1)+v2(i,j))) + enddo + modv(1,j)=modv(iip1,j) + enddo + +c les deux composantes du vent au pole sont obtenues comme +c premiers modes de fourier de v pres du pole + if (pole_nord) then + + upoln=0. + vpoln=0. + + do i=2,iip1 + zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) + zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) + vpn=vcov(i,1,1)/cv(i,1) + upoln=upoln+zco*vpn + vpoln=vpoln+zsi*vpn + enddo + vpn=sqrt(upoln*upoln+vpoln*vpoln)/pi + do i=1,iip1 +c modv(i,1)=vpn + modv(i,1)=modv(i,2) + enddo + + endif + + if (pole_sud) then + + upols=0. + vpols=0. + do i=2,iip1 + zco=cos(rlonv(i))*(rlonu(i)-rlonu(i-1)) + zsi=sin(rlonv(i))*(rlonu(i)-rlonu(i-1)) + vps=vcov(i,jjm,1)/cv(i,jjm) + upols=upols+zco*vps + vpols=vpols+zsi*vps + enddo + vps=sqrt(upols*upols+vpols*vpols)/pi + do i=1,iip1 +c modv(i,jjp1)=vps + modv(i,jjp1)=modv(i,jjm) + enddo + + endif + +c calcul du frottement au sol. + + jjb=jj_begin + jje=jj_end + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iim + ucov(i,j,1)=ucov(i,j,1) + s -cfric*pdt*0.5*(modv(i+1,j)+modv(i,j))*ucov(i,j,1) + enddo + ucov(iip1,j,1)=ucov(1,j,1) + enddo + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + do j=jjb,jje + do i=1,iip1 + vcov(i,j,1)=vcov(i,j,1) + s -cfric*pdt*0.5*(modv(i,j+1)+modv(i,j))*vcov(i,j,1) + enddo + vcov(iip1,j,1)=vcov(1,j,1) + enddo + + RETURN + END + Index: /LMDZ5/trunk/libf/dyn3dmem/fxhyp.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/fxhyp.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/fxhyp.F (revision 1632) @@ -0,0 +1,448 @@ +! +! $Id: fxhyp.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c +c + SUBROUTINE fxhyp ( xzoomdeg,grossism,dzooma,tau , + , rlonm025,xprimm025,rlonv,xprimv,rlonu,xprimu,rlonp025,xprimp025, + , champmin,champmax ) + +c Auteur : P. Le Van + + IMPLICIT NONE + +c Calcule les longitudes et derivees dans la grille du GCM pour une +c fonction f(x) a tangente hyperbolique . +c +c grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois,etc.) +c dzoom etant la distance totale de la zone du zoom +c tau la raideur de la transition de l'interieur a l'exterieur du zoom +c +c On doit avoir grossism x dzoom < pi ( radians ) , en longitude. +c ******************************************************************** + + + INTEGER nmax, nmax2 + PARAMETER ( nmax = 30000, nmax2 = 2*nmax ) +c + LOGICAL scal180 + PARAMETER ( scal180 = .TRUE. ) + +c scal180 = .TRUE. si on veut avoir le premier point scalaire pour +c une grille reguliere ( grossism = 1.,tau=0.,clon=0. ) a -180. degres. +c sinon scal180 = .FALSE. + +#include "dimensions.h" +#include "paramet.h" + +c ...... arguments d'entree ....... +c + REAL xzoomdeg,dzooma,tau,grossism + +c ...... arguments de sortie ...... + + REAL rlonm025(iip1),xprimm025(iip1),rlonv(iip1),xprimv(iip1), + , rlonu(iip1),xprimu(iip1),rlonp025(iip1),xprimp025(iip1) + +c .... variables locales .... +c + REAL dzoom + REAL*8 xlon(iip1),xprimm(iip1),xuv + REAL*8 xtild(0:nmax2) + REAL*8 fhyp(0:nmax2),ffdx,beta,Xprimt(0:nmax2) + REAL*8 Xf(0:nmax2),xxpr(0:nmax2) + REAL*8 xvrai(iip1),xxprim(iip1) + REAL*8 pi,depi,epsilon,xzoom,fa,fb + REAL*8 Xf1, Xfi , a0,a1,a2,a3,xi2 + INTEGER i,it,ik,iter,ii,idif,ii1,ii2 + REAL*8 xi,xo1,xmoy,xlon2,fxm,Xprimin + REAL*8 champmin,champmax,decalx + INTEGER is2 + SAVE is2 + + REAL*8 heavyside + + pi = 2. * ASIN(1.) + depi = 2. * pi + epsilon = 1.e-3 + xzoom = xzoomdeg * pi/180. +c + decalx = .75 + IF( grossism.EQ.1..AND.scal180 ) THEN + decalx = 1. + ENDIF + + WRITE(6,*) 'FXHYP scal180,decalx', scal180,decalx +c + IF( dzooma.LT.1.) THEN + dzoom = dzooma * depi + ELSEIF( dzooma.LT. 25. ) THEN + WRITE(6,*) ' Le param. dzoomx pour fxhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzooma * pi/180. + ENDIF + + WRITE(6,*) ' xzoom( rad.),grossism,tau,dzoom (radians)' + WRITE(6,24) xzoom,grossism,tau,dzoom + + DO i = 0, nmax2 + xtild(i) = - pi + REAL(i) * depi /nmax2 + ENDDO + + DO i = nmax, nmax2 + + fa = tau* ( dzoom/2. - xtild(i) ) + fb = xtild(i) * ( pi - xtild(i) ) + + IF( 200.* fb .LT. - fa ) THEN + fhyp ( i) = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fhyp ( i) = 1. + ELSE + IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13) THEN + IF( 200.*fb + fa.LT.1.e-10 ) THEN + fhyp ( i ) = - 1. + ELSEIF( 200.*fb - fa.LT.1.e-10 ) THEN + fhyp ( i ) = 1. + ENDIF + ELSE + fhyp ( i ) = TANH ( fa/fb ) + ENDIF + ENDIF + IF ( xtild(i).EQ. 0. ) fhyp(i) = 1. + IF ( xtild(i).EQ. pi ) fhyp(i) = -1. + + ENDDO + +cc .... Calcul de beta .... + + ffdx = 0. + + DO i = nmax +1,nmax2 + + xmoy = 0.5 * ( xtild(i-1) + xtild( i ) ) + fa = tau* ( dzoom/2. - xmoy ) + fb = xmoy * ( pi - xmoy ) + + IF( 200.* fb .LT. - fa ) THEN + fxm = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fxm = 1. + ELSE + IF( ABS(fa).LT.1.e-13.AND.ABS(fb).LT.1.e-13) THEN + IF( 200.*fb + fa.LT.1.e-10 ) THEN + fxm = - 1. + ELSEIF( 200.*fb - fa.LT.1.e-10 ) THEN + fxm = 1. + ENDIF + ELSE + fxm = TANH ( fa/fb ) + ENDIF + ENDIF + + IF ( xmoy.EQ. 0. ) fxm = 1. + IF ( xmoy.EQ. pi ) fxm = -1. + + ffdx = ffdx + fxm * ( xtild(i) - xtild(i-1) ) + + ENDDO + + beta = ( grossism * ffdx - pi ) / ( ffdx - pi ) + + IF( 2.*beta - grossism.LE. 0.) THEN + WRITE(6,*) ' ** Attention ! La valeur beta calculee dans la rou + ,tine fxhyp est mauvaise ! ' + WRITE(6,*)'Modifier les valeurs de grossismx ,tau ou dzoomx ', + , ' et relancer ! *** ' + CALL ABORT + ENDIF +c +c ..... calcul de Xprimt ..... +c + + DO i = nmax, nmax2 + Xprimt(i) = beta + ( grossism - beta ) * fhyp(i) + ENDDO +c + DO i = nmax+1, nmax2 + Xprimt( nmax2 - i ) = Xprimt( i ) + ENDDO +c + +c ..... Calcul de Xf ........ + + Xf(0) = - pi + + DO i = nmax +1, nmax2 + + xmoy = 0.5 * ( xtild(i-1) + xtild( i ) ) + fa = tau* ( dzoom/2. - xmoy ) + fb = xmoy * ( pi - xmoy ) + + IF( 200.* fb .LT. - fa ) THEN + fxm = - 1. + ELSEIF( 200. * fb .LT. fa ) THEN + fxm = 1. + ELSE + fxm = TANH ( fa/fb ) + ENDIF + + IF ( xmoy.EQ. 0. ) fxm = 1. + IF ( xmoy.EQ. pi ) fxm = -1. + xxpr(i) = beta + ( grossism - beta ) * fxm + + ENDDO + + DO i = nmax+1, nmax2 + xxpr(nmax2-i+1) = xxpr(i) + ENDDO + + DO i=1,nmax2 + Xf(i) = Xf(i-1) + xxpr(i) * ( xtild(i) - xtild(i-1) ) + ENDDO + + +c ***************************************************************** +c + +c ..... xuv = 0. si calcul aux pts scalaires ........ +c ..... xuv = 0.5 si calcul aux pts U ........ +c + WRITE(6,18) +c + DO 5000 ik = 1, 4 + + IF( ik.EQ.1 ) THEN + xuv = -0.25 + ELSE IF ( ik.EQ.2 ) THEN + xuv = 0. + ELSE IF ( ik.EQ.3 ) THEN + xuv = 0.50 + ELSE IF ( ik.EQ.4 ) THEN + xuv = 0.25 + ENDIF + + xo1 = 0. + + ii1=1 + ii2=iim + IF(ik.EQ.1.and.grossism.EQ.1.) THEN + ii1 = 2 + ii2 = iim+1 + ENDIF + DO 1500 i = ii1, ii2 + + xlon2 = - pi + (REAL(i) + xuv - decalx) * depi / REAL(iim) + + Xfi = xlon2 +c + DO 250 it = nmax2,0,-1 + IF( Xfi.GE.Xf(it)) GO TO 350 +250 CONTINUE + + it = 0 + +350 CONTINUE + +c ...... Calcul de Xf(xi) ...... +c + xi = xtild(it) + + IF(it.EQ.nmax2) THEN + it = nmax2 -1 + Xf(it+1) = pi + ENDIF +c ..................................................................... +c +c Appel de la routine qui calcule les coefficients a0,a1,a2,a3 d'un +c polynome de degre 3 qui passe par les points (Xf(it),xtild(it) ) +c et (Xf(it+1),xtild(it+1) ) + + CALL coefpoly ( Xf(it),Xf(it+1),Xprimt(it),Xprimt(it+1), + , xtild(it),xtild(it+1), a0, a1, a2, a3 ) + + Xf1 = Xf(it) + Xprimin = a1 + 2.* a2 * xi + 3.*a3 * xi *xi + + DO 500 iter = 1,300 + xi = xi - ( Xf1 - Xfi )/ Xprimin + + IF( ABS(xi-xo1).LE.epsilon) GO TO 550 + xo1 = xi + xi2 = xi * xi + Xf1 = a0 + a1 * xi + a2 * xi2 + a3 * xi2 * xi + Xprimin = a1 + 2.* a2 * xi + 3.* a3 * xi2 +500 CONTINUE + WRITE(6,*) ' Pas de solution ***** ',i,xlon2,iter + STOP 6 +550 CONTINUE + + xxprim(i) = depi/ ( REAL(iim) * Xprimin ) + xvrai(i) = xi + xzoom + +1500 CONTINUE + + + IF(ik.EQ.1.and.grossism.EQ.1.) THEN + xvrai(1) = xvrai(iip1)-depi + xxprim(1) = xxprim(iip1) + ENDIF + DO i = 1 , iim + xlon(i) = xvrai(i) + xprimm(i) = xxprim(i) + ENDDO + DO i = 1, iim -1 + IF( xvrai(i+1). LT. xvrai(i) ) THEN + WRITE(6,*) ' PBS. avec rlonu(',i+1,') plus petit que rlonu(',i, + , ')' + STOP 7 + ENDIF + ENDDO +c +c ... Reorganisation des longitudes pour les avoir entre - pi et pi .. +c ........................................................................ + + champmin = 1.e12 + champmax = -1.e12 + DO i = 1, iim + champmin = MIN( champmin,xvrai(i) ) + champmax = MAX( champmax,xvrai(i) ) + ENDDO + + IF(champmin .GE.-pi-0.10.and.champmax.LE.pi+0.10 ) THEN + GO TO 1600 + ELSE + WRITE(6,*) 'Reorganisation des longitudes pour avoir entre - pi', + , ' et pi ' +c + IF( xzoom.LE.0.) THEN + IF( ik.EQ. 1 ) THEN + DO i = 1, iim + IF( xvrai(i).GE. - pi ) GO TO 80 + ENDDO + WRITE(6,*) ' PBS. 1 ! Xvrai plus petit que - pi ! ' + STOP 8 + 80 CONTINUE + is2 = i + ENDIF + + IF( is2.NE. 1 ) THEN + DO ii = is2 , iim + xlon (ii-is2+1) = xvrai(ii) + xprimm(ii-is2+1) = xxprim(ii) + ENDDO + DO ii = 1 , is2 -1 + xlon (ii+iim-is2+1) = xvrai(ii) + depi + xprimm(ii+iim-is2+1) = xxprim(ii) + ENDDO + ENDIF + ELSE + IF( ik.EQ.1 ) THEN + DO i = iim,1,-1 + IF( xvrai(i).LE. pi ) GO TO 90 + ENDDO + WRITE(6,*) ' PBS. 2 ! Xvrai plus grand que pi ! ' + STOP 9 + 90 CONTINUE + is2 = i + ENDIF + idif = iim -is2 + DO ii = 1, is2 + xlon (ii+idif) = xvrai(ii) + xprimm(ii+idif) = xxprim(ii) + ENDDO + DO ii = 1, idif + xlon (ii) = xvrai (ii+is2) - depi + xprimm(ii) = xxprim(ii+is2) + ENDDO + ENDIF + ENDIF +c +c ......... Fin de la reorganisation ............................ + + 1600 CONTINUE + + + xlon ( iip1) = xlon(1) + depi + xprimm( iip1 ) = xprimm (1 ) + + DO i = 1, iim+1 + xvrai(i) = xlon(i)*180./pi + ENDDO + + IF( ik.EQ.1 ) THEN +c WRITE(6,*) ' XLON aux pts. V-0.25 apres ( en deg. ) ' +c WRITE(6,18) +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM k ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim +1 + rlonm025(i) = xlon( i ) + xprimm025(i) = xprimm(i) + ENDDO + ELSE IF( ik.EQ.2 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. V apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM k ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonv(i) = xlon( i ) + xprimv(i) = xprimm(i) + ENDDO + + ELSE IF( ik.EQ.3) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. U apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM ik ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonu(i) = xlon( i ) + xprimu(i) = xprimm(i) + ENDDO + + ELSE IF( ik.EQ.4 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' XLON aux pts. V+0.25 apres ( en deg. ) ' +c WRITE(6,68) xvrai +c WRITE(6,*) ' XPRIM ik ',ik +c WRITE(6,566) xprimm + + DO i = 1,iim + 1 + rlonp025(i) = xlon( i ) + xprimp025(i) = xprimm(i) + ENDDO + + ENDIF + +5000 CONTINUE +c + WRITE(6,18) +c +c ........... fin de la boucle do 5000 ............ + + DO i = 1, iim + xlon(i) = rlonv(i+1) - rlonv(i) + ENDDO + champmin = 1.e12 + champmax = -1.e12 + DO i = 1, iim + champmin = MIN( champmin, xlon(i) ) + champmax = MAX( champmax, xlon(i) ) + ENDDO + champmin = champmin * 180./pi + champmax = champmax * 180./pi + +18 FORMAT(/) +24 FORMAT(2x,'Parametres xzoom,gross,tau ,dzoom pour fxhyp ',4f8.3) +68 FORMAT(1x,7f9.2) +566 FORMAT(1x,7f9.4) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/fxy.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/fxy.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/fxy.F (revision 1632) @@ -0,0 +1,69 @@ +! +! $Id: fxy.F 1299 2010-01-20 14:27:21Z fairhead $ +! + 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/dyn3dmem/fxyhyper.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/fxyhyper.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/fxyhyper.F (revision 1632) @@ -0,0 +1,139 @@ +! +! $Header$ +! +c +c + SUBROUTINE fxyhyper ( yzoom, grossy, dzoomy,tauy , + , xzoom, grossx, dzoomx,taux , + , rlatu,yprimu,rlatv,yprimv,rlatu1, yprimu1, rlatu2, yprimu2 , + , rlonu,xprimu,rlonv,xprimv,rlonm025,xprimm025,rlonp025,xprimp025) + + IMPLICIT NONE +c +c Auteur : P. Le Van . +c +c d'apres formulations de R. Sadourny . +c +c +c Ce spg calcule les latitudes( routine fyhyp ) et longitudes( fxhyp ) +c par des fonctions a tangente hyperbolique . +c +c Il y a 3 parametres ,en plus des coordonnees du centre du zoom (xzoom +c et yzoom ) : +c +c a) le grossissement du zoom : grossy ( en y ) et grossx ( en x ) +c b) l' extension du zoom : dzoomy ( en y ) et dzoomx ( en x ) +c c) la raideur de la transition du zoom : taux et tauy +c +c N.B : Il vaut mieux avoir : grossx * dzoomx < pi ( radians ) +c ****** +c et grossy * dzoomy < pi/2 ( radians ) +c +#include "dimensions.h" +#include "paramet.h" + + +c ..... Arguments ... +c + REAL xzoom,yzoom,grossx,grossy,dzoomx,dzoomy,taux,tauy + REAL rlatu(jjp1), yprimu(jjp1),rlatv(jjm), yprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + REAL rlonu(iip1),xprimu(iip1),rlonv(iip1),xprimv(iip1), + , rlonm025(iip1),xprimm025(iip1), rlonp025(iip1),xprimp025(iip1) + REAL(KIND=8) dxmin, dxmax , dymin, dymax + +c .... var. locales ..... +c + INTEGER i,j +c + + CALL fyhyp ( yzoom, grossy, dzoomy,tauy , + , rlatu, yprimu,rlatv,yprimv,rlatu2,yprimu2,rlatu1,yprimu1 , + , dymin,dymax ) + + CALL fxhyp(xzoom,grossx,dzoomx,taux,rlonm025,xprimm025,rlonv, + , xprimv,rlonu,xprimu,rlonp025,xprimp025 , dxmin,dxmax ) + + + DO i = 1, iip1 + IF(rlonp025(i).LT.rlonv(i)) THEN + WRITE(6,*) ' Attention ! rlonp025 < rlonv',i + STOP + ENDIF + + IF(rlonv(i).LT.rlonm025(i)) THEN + WRITE(6,*) ' Attention ! rlonm025 > rlonv',i + STOP + ENDIF + + IF(rlonp025(i).GT.rlonu(i)) THEN + WRITE(6,*) ' Attention ! rlonp025 > rlonu',i + STOP + ENDIF + ENDDO + + WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FX **** ' + +c + DO j = 1, jjm +c + IF(rlatu1(j).LE.rlatu2(j)) THEN + WRITE(6,*)'Attention ! rlatu1 < rlatu2 ',rlatu1(j), rlatu2(j),j + STOP 13 + ENDIF +c + IF(rlatu2(j).LE.rlatu(j+1)) THEN + WRITE(6,*)'Attention ! rlatu2 < rlatup1 ',rlatu2(j),rlatu(j+1),j + STOP 14 + ENDIF +c + IF(rlatu(j).LE.rlatu1(j)) THEN + WRITE(6,*)' Attention ! rlatu < rlatu1 ',rlatu(j),rlatu1(j),j + STOP 15 + ENDIF +c + IF(rlatv(j).LE.rlatu2(j)) THEN + WRITE(6,*)' Attention ! rlatv < rlatu2 ',rlatv(j),rlatu2(j),j + STOP 16 + ENDIF +c + IF(rlatv(j).ge.rlatu1(j)) THEN + WRITE(6,*)' Attention ! rlatv > rlatu1 ',rlatv(j),rlatu1(j),j + STOP 17 + ENDIF +c + IF(rlatv(j).ge.rlatu(j)) THEN + WRITE(6,*) ' Attention ! rlatv > rlatu ',rlatv(j),rlatu(j),j + STOP 18 + ENDIF +c + ENDDO +c + WRITE(6,*) ' *** TEST DE COHERENCE OK POUR FY **** ' +c + WRITE(6,18) + WRITE(6,*) ' Latitudes ' + WRITE(6,*) ' *********** ' + WRITE(6,18) + WRITE(6,3) dymin, dymax + WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par + ,ametres grossism , tau , dzoom pour Y et repasser ! ' +c + WRITE(6,18) + WRITE(6,*) ' Longitudes ' + WRITE(6,*) ' ************ ' + WRITE(6,18) + WRITE(6,3) dxmin, dxmax + WRITE(6,*) ' Si cette derniere est trop lache , modifiez les par + ,ametres grossism , tau , dzoom pour Y et repasser ! ' + WRITE(6,18) +c +3 Format(1x, ' Au centre du zoom , la longueur de la maille est', + , ' d environ ',f8.2 ,' degres ', + , ' alors que la maille en dehors de la zone du zoom est d environ + , ', f8.2,' degres ' ) +18 FORMAT(/) + + RETURN + END + Index: /LMDZ5/trunk/libf/dyn3dmem/fxysinus.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/fxysinus.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/fxysinus.F (revision 1632) @@ -0,0 +1,69 @@ +! +! $Id: fxysinus.F 1299 2010-01-20 14:27:21Z fairhead $ +! + 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/dyn3dmem/fyhyp.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/fyhyp.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/fyhyp.F (revision 1632) @@ -0,0 +1,378 @@ +! +! $Id: fyhyp.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c +c + SUBROUTINE fyhyp ( yzoomdeg, grossism, dzooma,tau , + , rrlatu,yyprimu,rrlatv,yyprimv,rlatu2,yprimu2,rlatu1,yprimu1 , + , champmin,champmax ) + +cc ... Version du 01/04/2001 .... + + IMPLICIT NONE +c +c ... Auteur : P. Le Van ... +c +c ....... d'apres formulations de R. Sadourny ....... +c +c Calcule les latitudes et derivees dans la grille du GCM pour une +c fonction f(y) a tangente hyperbolique . +c +c grossism etant le grossissement ( = 2 si 2 fois, = 3 si 3 fois , etc) +c dzoom etant la distance totale de la zone du zoom ( en radians ) +c tau la raideur de la transition de l'interieur a l'exterieur du zoom +c +c +c N.B : Il vaut mieux avoir : grossism * dzoom < pi/2 (radians) ,en lati. +c ******************************************************************** +c +c +#include "dimensions.h" +#include "paramet.h" + + INTEGER nmax , nmax2 + PARAMETER ( nmax = 30000, nmax2 = 2*nmax ) +c +c +c ....... arguments d'entree ....... +c + REAL yzoomdeg, grossism,dzooma,tau +c ( rentres par run.def ) + +c ....... arguments de sortie ....... +c + REAL rrlatu(jjp1), yyprimu(jjp1),rrlatv(jjm), yyprimv(jjm), + , rlatu1(jjm), yprimu1(jjm), rlatu2(jjm), yprimu2(jjm) + +c +c ..... champs locaux ..... +c + + REAL dzoom + REAL(KIND=8) ylat(jjp1), yprim(jjp1) + REAL(KIND=8) yuv + REAL(KIND=8) yt(0:nmax2) + REAL(KIND=8) fhyp(0:nmax2),beta,Ytprim(0:nmax2),fxm(0:nmax2) + SAVE Ytprim, yt,Yf + REAL(KIND=8) Yf(0:nmax2),yypr(0:nmax2) + REAL(KIND=8) yvrai(jjp1), yprimm(jjp1),ylatt(jjp1) + REAL(KIND=8) pi,depi,pis2,epsilon,y0,pisjm + REAL(KIND=8) yo1,yi,ylon2,ymoy,Yprimin,champmin,champmax + REAL(KIND=8) yfi,Yf1,ffdy + REAL(KIND=8) ypn,deply,y00 + SAVE y00, deply + + INTEGER i,j,it,ik,iter,jlat + INTEGER jpn,jjpn + SAVE jpn + REAL(KIND=8) a0,a1,a2,a3,yi2,heavyy0,heavyy0m + REAL(KIND=8) fa(0:nmax2),fb(0:nmax2) + REAL y0min,y0max + + REAL(KIND=8) heavyside + + pi = 2. * ASIN(1.) + depi = 2. * pi + pis2 = pi/2. + pisjm = pi/ REAL(jjm) + epsilon = 1.e-3 + y0 = yzoomdeg * pi/180. + + IF( dzooma.LT.1.) THEN + dzoom = dzooma * pi + ELSEIF( dzooma.LT. 12. ) THEN + WRITE(6,*) ' Le param. dzoomy pour fyhyp est trop petit ! L aug + ,menter et relancer ! ' + STOP 1 + ELSE + dzoom = dzooma * pi/180. + ENDIF + + WRITE(6,18) + WRITE(6,*) ' yzoom( rad.),grossism,tau,dzoom (radians)' + WRITE(6,24) y0,grossism,tau,dzoom + + DO i = 0, nmax2 + yt(i) = - pis2 + REAL(i)* pi /nmax2 + ENDDO + + heavyy0m = heavyside( -y0 ) + heavyy0 = heavyside( y0 ) + y0min = 2.*y0*heavyy0m - pis2 + y0max = 2.*y0*heavyy0 + pis2 + + fa = 999.999 + fb = 999.999 + + DO i = 0, nmax2 + IF( yt(i).LT.y0 ) THEN + fa (i) = tau* (yt(i)-y0+dzoom/2. ) + fb(i) = (yt(i)-2.*y0*heavyy0m +pis2) * ( y0 - yt(i) ) + ELSEIF ( yt(i).GT.y0 ) THEN + fa(i) = tau *(y0-yt(i)+dzoom/2. ) + fb(i) = (2.*y0*heavyy0 -yt(i)+pis2) * ( yt(i) - y0 ) + ENDIF + + IF( 200.* fb(i) .LT. - fa(i) ) THEN + fhyp ( i) = - 1. + ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN + fhyp ( i) = 1. + ELSE + fhyp(i) = TANH ( fa(i)/fb(i) ) + ENDIF + + IF( yt(i).EQ.y0 ) fhyp(i) = 1. + IF(yt(i).EQ. y0min. OR.yt(i).EQ. y0max ) fhyp(i) = -1. + + ENDDO + +cc .... Calcul de beta .... +c + ffdy = 0. + + DO i = 1, nmax2 + ymoy = 0.5 * ( yt(i-1) + yt( i ) ) + IF( ymoy.LT.y0 ) THEN + fa(i)= tau * ( ymoy-y0+dzoom/2.) + fb(i) = (ymoy-2.*y0*heavyy0m +pis2) * ( y0 - ymoy ) + ELSEIF ( ymoy.GT.y0 ) THEN + fa(i)= tau * ( y0-ymoy+dzoom/2. ) + fb(i) = (2.*y0*heavyy0 -ymoy+pis2) * ( ymoy - y0 ) + ENDIF + + IF( 200.* fb(i) .LT. - fa(i) ) THEN + fxm ( i) = - 1. + ELSEIF( 200. * fb(i) .LT. fa(i) ) THEN + fxm ( i) = 1. + ELSE + fxm(i) = TANH ( fa(i)/fb(i) ) + ENDIF + IF( ymoy.EQ.y0 ) fxm(i) = 1. + IF (ymoy.EQ. y0min. OR.yt(i).EQ. y0max ) fxm(i) = -1. + ffdy = ffdy + fxm(i) * ( yt(i) - yt(i-1) ) + + ENDDO + + beta = ( grossism * ffdy - pi ) / ( ffdy - pi ) + + IF( 2.*beta - grossism.LE. 0.) THEN + + WRITE(6,*) ' ** Attention ! La valeur beta calculee dans la rou + ,tine fyhyp est mauvaise ! ' + WRITE(6,*)'Modifier les valeurs de grossismy ,tauy ou dzoomy', + , ' et relancer ! *** ' + CALL ABORT + + ENDIF +c +c ..... calcul de Ytprim ..... +c + + DO i = 0, nmax2 + Ytprim(i) = beta + ( grossism - beta ) * fhyp(i) + ENDDO + +c ..... Calcul de Yf ........ + + Yf(0) = - pis2 + DO i = 1, nmax2 + yypr(i) = beta + ( grossism - beta ) * fxm(i) + ENDDO + + DO i=1,nmax2 + Yf(i) = Yf(i-1) + yypr(i) * ( yt(i) - yt(i-1) ) + ENDDO + +c **************************************************************** +c +c ..... yuv = 0. si calcul des latitudes aux pts. U ..... +c ..... yuv = 0.5 si calcul des latitudes aux pts. V ..... +c + WRITE(6,18) +c + DO 5000 ik = 1,4 + + IF( ik.EQ.1 ) THEN + yuv = 0. + jlat = jjm + 1 + ELSE IF ( ik.EQ.2 ) THEN + yuv = 0.5 + jlat = jjm + ELSE IF ( ik.EQ.3 ) THEN + yuv = 0.25 + jlat = jjm + ELSE IF ( ik.EQ.4 ) THEN + yuv = 0.75 + jlat = jjm + ENDIF +c + yo1 = 0. + DO 1500 j = 1,jlat + yo1 = 0. + ylon2 = - pis2 + pisjm * ( REAL(j) + yuv -1.) + yfi = ylon2 +c + DO 250 it = nmax2,0,-1 + IF( yfi.GE.Yf(it)) GO TO 350 +250 CONTINUE + it = 0 +350 CONTINUE + + yi = yt(it) + IF(it.EQ.nmax2) THEN + it = nmax2 -1 + Yf(it+1) = pis2 + ENDIF +c ................................................................. +c .... Interpolation entre yi(it) et yi(it+1) pour avoir Y(yi) +c ..... et Y'(yi) ..... +c ................................................................. + + CALL coefpoly ( Yf(it),Yf(it+1),Ytprim(it), Ytprim(it+1), + , yt(it),yt(it+1) , a0,a1,a2,a3 ) + + Yf1 = Yf(it) + Yprimin = a1 + 2.* a2 * yi + 3.*a3 * yi *yi + + DO 500 iter = 1,300 + yi = yi - ( Yf1 - yfi )/ Yprimin + + IF( ABS(yi-yo1).LE.epsilon) GO TO 550 + yo1 = yi + yi2 = yi * yi + Yf1 = a0 + a1 * yi + a2 * yi2 + a3 * yi2 * yi + Yprimin = a1 + 2.* a2 * yi + 3.* a3 * yi2 +500 CONTINUE + WRITE(6,*) ' Pas de solution ***** ',j,ylon2,iter + STOP 2 +550 CONTINUE +c + Yprimin = a1 + 2.* a2 * yi + 3.* a3 * yi* yi + yprim(j) = pi / ( jjm * Yprimin ) + yvrai(j) = yi + +1500 CONTINUE + + DO j = 1, jlat -1 + IF( yvrai(j+1). LT. yvrai(j) ) THEN + WRITE(6,*) ' PBS. avec rlat(',j+1,') plus petit que rlat(',j, + , ')' + STOP 3 + ENDIF + ENDDO + + WRITE(6,*) 'Reorganisation des latitudes pour avoir entre - pi/2' + , ,' et pi/2 ' +c + IF( ik.EQ.1 ) THEN + ypn = pis2 + DO j = jlat,1,-1 + IF( yvrai(j).LE. ypn ) GO TO 1502 + ENDDO +1502 CONTINUE + + jpn = j + y00 = yvrai(jpn) + deply = pis2 - y00 + ENDIF + + DO j = 1, jjm +1 - jpn + ylatt (j) = -pis2 - y00 + yvrai(jpn+j-1) + yprimm(j) = yprim(jpn+j-1) + ENDDO + + jjpn = jpn + IF( jlat.EQ. jjm ) jjpn = jpn -1 + + DO j = 1,jjpn + ylatt (j + jjm+1 -jpn) = yvrai(j) + deply + yprimm(j + jjm+1 -jpn) = yprim(j) + ENDDO + +c *********** Fin de la reorganisation ************* +c + 1600 CONTINUE + + DO j = 1, jlat + ylat(j) = ylatt( jlat +1 -j ) + yprim(j) = yprimm( jlat +1 -j ) + ENDDO + + DO j = 1, jlat + yvrai(j) = ylat(j)*180./pi + ENDDO + + IF( ik.EQ.1 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rrlatu(j) = ylat( j ) + yyprimu(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 2 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en V apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*)' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rrlatv(j) = ylat( j ) + yyprimv(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 3 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U + 0.75 apres ( en deg. ) ' +c WRITE(6,68) (yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,445) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rlatu2(j) = ylat( j ) + yprimu2(j) = yprim( j ) + ENDDO + + ELSE IF ( ik.EQ. 4 ) THEN +c WRITE(6,18) +c WRITE(6,*) ' YLAT en U + 0.25 apres ( en deg. ) ' +c WRITE(6,68)(yvrai(j),j=1,jlat) +cc WRITE(6,*) ' YPRIM ' +cc WRITE(6,68) ( yprim(j),j=1,jlat) + + DO j = 1, jlat + rlatu1(j) = ylat( j ) + yprimu1(j) = yprim( j ) + ENDDO + + ENDIF + +5000 CONTINUE +c + WRITE(6,18) +c +c ..... fin de la boucle do 5000 ..... + + DO j = 1, jjm + ylat(j) = rrlatu(j) - rrlatu(j+1) + ENDDO + champmin = 1.e12 + champmax = -1.e12 + DO j = 1, jjm + champmin = MIN( champmin, ylat(j) ) + champmax = MAX( champmax, ylat(j) ) + ENDDO + champmin = champmin * 180./pi + champmax = champmax * 180./pi + +24 FORMAT(2x,'Parametres yzoom,gross,tau ,dzoom pour fyhyp ',4f8.3) +18 FORMAT(/) +68 FORMAT(1x,7f9.2) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gcm.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gcm.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gcm.F (revision 1632) @@ -0,0 +1,521 @@ +! +! $Id: gcm.F 1316 2010-02-22 14:51:12Z acozic $ +! +c +c + PROGRAM gcm + +#ifdef CPP_IOIPSL + USE IOIPSL +#endif + + USE mod_const_mpi, ONLY: init_const_mpi + USE parallel + USE infotrac + USE mod_interface_dyn_phys + USE mod_hallo + USE Bands + USE getparam + USE filtreg_mod + USE control_mod + +! Ehouarn: for now these only apply to Earth: +#ifdef CPP_EARTH + USE mod_grid_phy_lmdz + USE mod_phys_lmdz_para, ONLY : klon_mpi_para_nb + USE mod_phys_lmdz_omp_data, ONLY: klon_omp + USE dimphy + USE comgeomphy +#endif + IMPLICIT NONE + +c ...... Version du 10/01/98 .......... + +c avec coordonnees verticales hybrides +c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) + +c======================================================================= +c +c Auteur: P. Le Van /L. Fairhead/F.Hourdin +c ------- +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +c +c======================================================================= +c +c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv +c et possibilite d'appeler une fonction f(y) a derivee tangente +c hyperbolique a la place de la fonction a derivee sinusoidale. +c ... Possibilite de choisir le schema pour l'advection de +c q , en modifiant iadv dans traceur.def (MAF,10/02) . +c +c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) +c Pour Van-Leer iadv=10 +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissnew.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" +#include "serre.h" +#include "com_io_dyn.h" +#include "iniprint.h" +#include "tracstoke.h" +#include "indicesol.h" + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + SAVE clesphy0 + + + + REAL zdtvr +c INTEGER nbetatmoy, nbetatdem,nbetat + INTEGER nbetatmoy, nbetatdem + +c variables dynamiques + REAL,ALLOCATABLE,SAVE :: vcov(:,:),ucov(:,:) ! vents covariants + REAL,ALLOCATABLE,SAVE :: teta(:,:) ! temperature potentielle + REAL, ALLOCATABLE,SAVE :: q(:,:,:) ! champs advectes + REAL,ALLOCATABLE,SAVE :: ps(:) ! pression au sol +c REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches +c REAL pks(ip1jmp1) ! exner au sol +c REAL pk(ip1jmp1,llm) ! exner au milieu des couches +c REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL,ALLOCATABLE,SAVE :: masse(:,:) ! masse d'air + REAL,ALLOCATABLE,SAVE :: phis(:) ! geopotentiel au sol +c REAL phi(ip1jmp1,llm) ! geopotentiel +c REAL w(ip1jmp1,llm) ! vitesse verticale + +c variables dynamiques intermediaire pour le transport + +c variables pour le fichier histoire + REAL dtav ! intervalle de temps elementaire + + REAL time_0 + + LOGICAL lafin +c INTEGER ij,iq,l,i,j + INTEGER i,j + + + real time_step, t_wrt, t_ops + + + LOGICAL call_iniphys + data call_iniphys/.true./ + +c REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm) +c+jld variables test conservation energie +c REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) +C Tendance de la temp. potentiel d (theta)/ d t due a la +C tansformation d'energie cinetique en energie thermique +C cree par la dissipation +c REAL dhecdt(ip1jmp1,llm) +c REAL vcont(ip1jm,llm),ucont(ip1jmp1,llm) +c REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec +c CHARACTER (len=15) :: ztit +c-jld + + + character (len=80) :: dynhist_file, dynhistave_file + character (len=20) :: modname + character (len=80) :: abort_message +! locales pour gestion du temps + INTEGER :: an, mois, jour + REAL :: heure + + +c----------------------------------------------------------------------- +c variables pour l'initialisation de la physique : +c ------------------------------------------------ + INTEGER ngridmx + PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm ) + REAL zcufi(ngridmx),zcvfi(ngridmx) + REAL latfi(ngridmx),lonfi(ngridmx) + REAL airefi(ngridmx) + SAVE latfi, lonfi, airefi + + INTEGER :: ierr + + +c----------------------------------------------------------------------- +c Initialisations: +c ---------------- + + abort_message = 'last timestep reached' + modname = 'gcm' + descript = 'Run GCM LMDZ' + lafin = .FALSE. + dynhist_file = 'dyn_hist' + dynhistave_file = 'dyn_hist_ave' + + + +c---------------------------------------------------------------------- +c lecture des fichiers gcm.def ou run.def +c --------------------------------------- +c +! Ehouarn: dump possibility of using defrun +!#ifdef CPP_IOIPSL + CALL conf_gcm( 99, .TRUE. , clesphy0 ) +!#else +! CALL defrun( 99, .TRUE. , clesphy0 ) +!#endif +c +c +c------------------------------------ +c Initialisation partie parallele +c------------------------------------ + CALL init_const_mpi + + call init_parallel + call ini_getparam("out.def") + call Read_Distrib +! Ehouarn : temporarily (?) keep this only for Earth + if (planet_type.eq."earth") then +#ifdef CPP_EARTH + CALL Init_Phys_lmdz(iim,jjp1,llm,mpi_size,distrib_phys) +#endif + endif ! of if (planet_type.eq."earth") + CALL set_bands +#ifdef CPP_EARTH +! Ehouarn: For now only Earth physics is parallel + CALL Init_interface_dyn_phys +#endif + CALL barrier + + if (mpi_rank==0) call WriteBands + call Set_Distrib(distrib_caldyn) + +c$OMP PARALLEL + call Init_Mod_hallo +c$OMP END PARALLEL + +! Ehouarn : temporarily (?) keep this only for Earth + if (planet_type.eq."earth") then +#ifdef CPP_EARTH +c$OMP PARALLEL + call InitComgeomphy +c$OMP END PARALLEL +#endif + endif ! of if (planet_type.eq."earth") + +c----------------------------------------------------------------------- +c Choix du calendrier +c ------------------- + +c calend = 'earth_365d' + +#ifdef CPP_IOIPSL + if (calend == 'earth_360d') then + call ioconf_calendar('360d') + write(lunout,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an' + else if (calend == 'earth_365d') then + call ioconf_calendar('noleap') + write(lunout,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an' + else if (calend == 'earth_366d') then + call ioconf_calendar('gregorian') + write(lunout,*)'CALENDRIER CHOISI: Terrestre bissextile' + else + abort_message = 'Mauvais choix de calendrier' + call abort_gcm(modname,abort_message,1) + endif +#endif + + IF (config_inca /= 'none') THEN +#ifdef INCA + call init_const_lmdz( + $ nbtr,anneeref,dayref, + $ iphysiq,day_step,nday, + $ nbsrf, is_oce,is_sic, + $ is_ter,is_lic) + + call init_inca_para( + $ iim,jjm+1,llm,klon_glo,mpi_size, + $ distrib_phys,COMM_LMDZ) +#endif + END IF + +c----------------------------------------------------------------------- +c Initialisation des traceurs +c --------------------------- +c Choix du nombre de traceurs et du schema pour l'advection +c dans fichier traceur.def, par default ou via INCA + call infotrac_init + +c Allocation de la tableau q : champs advectes + ALLOCATE(ucov(ijb_u:ije_u,llm)) + ALLOCATE(vcov(ijb_v:ije_v,llm)) + ALLOCATE(teta(ijb_u:ije_u,llm)) + ALLOCATE(masse(ijb_u:ije_u,llm)) + ALLOCATE(ps(ijb_u:ije_u)) + ALLOCATE(phis(ijb_u:ije_u)) + ALLOCATE(q(ijb_u:ije_u,llm,nqtot)) + +c----------------------------------------------------------------------- +c Lecture de l'etat initial : +c --------------------------- + +c lecture du fichier start.nc + if (read_start) then + ! we still need to run iniacademic to initialize some + ! constants & fields, if we run the 'newtonian' case: + if (iflag_phys.eq.2) then + CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + endif +!#ifdef CPP_IOIPSL + if (planet_type.eq."earth") then +#ifdef CPP_EARTH +! Load an Earth-format start file + CALL dynetat0_loc("start.nc",vcov,ucov, + . teta,q,masse,ps,phis, time_0) +#endif + endif ! of if (planet_type.eq."earth") +c write(73,*) 'ucov',ucov +c write(74,*) 'vcov',vcov +c write(75,*) 'teta',teta +c write(76,*) 'ps',ps +c write(77,*) 'q',q + + endif ! of if (read_start) + +c le cas echeant, creation d un etat initial + IF (prt_level > 9) WRITE(lunout,*) + . 'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT' + if (.not.read_start) then + CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + endif + +c----------------------------------------------------------------------- +c Lecture des parametres de controle pour la simulation : +c ------------------------------------------------------- +c on recalcule eventuellement le pas de temps + + IF(MOD(day_step,iperiod).NE.0) THEN + abort_message = + . 'Il faut choisir un nb de pas par jour multiple de iperiod' + call abort_gcm(modname,abort_message,1) + ENDIF + + IF(MOD(day_step,iphysiq).NE.0) THEN + abort_message = + * 'Il faut choisir un nb de pas par jour multiple de iphysiq' + call abort_gcm(modname,abort_message,1) + ENDIF + + zdtvr = daysec/REAL(day_step) + IF(dtvr.NE.zdtvr) THEN + WRITE(lunout,*) + . 'WARNING!!! changement de pas de temps',dtvr,'>',zdtvr + ENDIF + +C +C on remet le calendrier à zero si demande +c + if (annee_ref .ne. anneeref .or. day_ref .ne. dayref) then + write(lunout,*) + . 'GCM: Attention les dates initiales lues dans le fichier' + write(lunout,*) + . ' restart ne correspondent pas a celles lues dans ' + write(lunout,*)' gcm.def' + write(lunout,*)' annee_ref=',annee_ref," anneeref=",anneeref + write(lunout,*)' day_ref=',day_ref," dayref=",dayref + if (raz_date .ne. 1) then + write(lunout,*) + . 'GCM: On garde les dates du fichier restart' + else + annee_ref = anneeref + day_ref = dayref + day_ini = dayref + itau_dyn = 0 + itau_phy = 0 + time_0 = 0. + write(lunout,*) + . 'GCM: On reinitialise a la date lue dans gcm.def' + endif + ELSE + raz_date = 0 + endif + +#ifdef CPP_IOIPSL + mois = 1 + heure = 0. + call ymds2ju(annee_ref, mois, day_ref, heure, jD_ref) + jH_ref = jD_ref - int(jD_ref) + jD_ref = int(jD_ref) + + call ioconf_startdate(INT(jD_ref), jH_ref) + + write(lunout,*)'DEBUG' + write(lunout,*)'annee_ref, mois, day_ref, heure, jD_ref' + write(lunout,*)annee_ref, mois, day_ref, heure, jD_ref + call ju2ymds(jD_ref+jH_ref,an, mois, jour, heure) + write(lunout,*)'jD_ref+jH_ref,an, mois, jour, heure' + write(lunout,*)jD_ref+jH_ref,an, mois, jour, heure +#else +! Ehouarn: we still need to define JD_ref and JH_ref +! and since we don't know how many days there are in a year +! we set JD_ref to 0 (this should be improved ...) + jD_ref=0 + jH_ref=0 +#endif + +c nombre d'etats dans les fichiers demarrage et histoire + nbetatdem = nday / iecri + nbetatmoy = nday / periodav + 1 + +c----------------------------------------------------------------------- +c Initialisation des constantes dynamiques : +c ------------------------------------------ + dtvr = zdtvr + CALL iniconst + +c----------------------------------------------------------------------- +c Initialisation de la geometrie : +c -------------------------------- + CALL inigeom + +c----------------------------------------------------------------------- +c Initialisation du filtre : +c -------------------------- + CALL inifilr +c +c----------------------------------------------------------------------- +c Initialisation de la dissipation : +c ---------------------------------- + + CALL inidissip( lstardis, nitergdiv, nitergrot, niterh , + * tetagdiv, tetagrot , tetatemp ) + +c----------------------------------------------------------------------- +c Initialisation de la physique : +c ------------------------------- + IF (call_iniphys.and.iflag_phys.eq.1) THEN + latfi(1)=rlatu(1) + lonfi(1)=0. + zcufi(1) = cu(1) + zcvfi(1) = cv(1) + DO j=2,jjm + DO i=1,iim + latfi((j-2)*iim+1+i)= rlatu(j) + lonfi((j-2)*iim+1+i)= rlonv(i) + zcufi((j-2)*iim+1+i) = cu((j-1)*iip1+i) + zcvfi((j-2)*iim+1+i) = cv((j-1)*iip1+i) + ENDDO + ENDDO + latfi(ngridmx)= rlatu(jjp1) + lonfi(ngridmx)= 0. + zcufi(ngridmx) = cu(ip1jm+1) + zcvfi(ngridmx) = cv(ip1jm-iim) + CALL gr_dyn_fi(1,iip1,jjp1,ngridmx,aire,airefi) + + WRITE(lunout,*) + . 'GCM: WARNING!!! vitesse verticale nulle dans la physique' +! Earth: + if (planet_type.eq."earth") then +#ifdef CPP_EARTH + CALL iniphysiq(ngridmx,llm,daysec,day_ini,dtphys , + , latfi,lonfi,airefi,zcufi,zcvfi,rad,g,r,cpp ) +#endif + endif ! of if (planet_type.eq."earth") + call_iniphys=.false. + ENDIF ! of IF (call_iniphys.and.(iflag_phys.eq.1)) + + +c----------------------------------------------------------------------- +c Initialisation des dimensions d'INCA : +c -------------------------------------- + IF (config_inca /= 'none') THEN +!$OMP PARALLEL +#ifdef INCA + CALL init_inca_dim(klon_omp,llm,iim,jjm, + $ rlonu,rlatu,rlonv,rlatv) +#endif +!$OMP END PARALLEL + END IF + +c----------------------------------------------------------------------- +c Initialisation des I/O : +c ------------------------ + + + day_end = day_ini + nday + WRITE(lunout,300)day_ini,day_end + 300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//) + +#ifdef CPP_IOIPSL + call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure) + write (lunout,301)jour, mois, an + call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure) + write (lunout,302)jour, mois, an + 301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4) + 302 FORMAT('1'/,15x,' au ', i2,'/',i2,'/',i4) +#endif + + if (planet_type.eq."earth") then + CALL dynredem0_loc("restart.nc", day_end, phis) + endif + + ecripar = .TRUE. + +#ifdef CPP_IOIPSL + if ( 1.eq.1) then + time_step = zdtvr + t_ops = iecri * daysec + t_wrt = iecri * daysec +! CALL inithist_p(dynhist_file,day_ref,annee_ref,time_step, +! . t_ops, t_wrt, histid, histvid) + + IF (ok_dyn_ave) THEN + t_ops = iperiod * time_step + t_wrt = periodav * daysec + CALL initdynav_loc(day_ref,annee_ref,time_step,t_ops,t_wrt) + END IF + dtav = iperiod*dtvr/daysec + endif + + +#endif +! #endif of #ifdef CPP_IOIPSL + +c Choix des frequences de stokage pour le offline +c istdyn=day_step/4 ! stockage toutes les 6h=1jour/4 +c istdyn=day_step/12 ! stockage toutes les 2h=1jour/12 + istdyn=day_step/4 ! stockage toutes les 6h=1jour/12 + istphy=istdyn/iphysiq + + +c +c----------------------------------------------------------------------- +c Integration temporelle du modele : +c ---------------------------------- + +c write(78,*) 'ucov',ucov +c write(78,*) 'vcov',vcov +c write(78,*) 'teta',teta +c write(78,*) 'ps',ps +c write(78,*) 'q',q + +c$OMP PARALLEL DEFAULT(SHARED) COPYIN(/temps/,/logic/) + CALL leapfrog_loc(ucov,vcov,teta,ps,masse,phis,q,clesphy0, + . time_0) +c$OMP END PARALLEL + + OPEN(unit=5487,file='ok_lmdz',status='replace') + WRITE(5487,*) 'ok_lmdz' + CLOSE(5487) + END + Index: /LMDZ5/trunk/libf/dyn3dmem/geopot.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/geopot.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/geopot.F (revision 1632) @@ -0,0 +1,64 @@ +! +! $Header$ +! + SUBROUTINE geopot (ngrid, teta, pk, pks, phis, phi ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul du geopotentiel aux milieux des couches ..... +c ******************************************************************* +c +c .... l'integration se fait de bas en haut .... +c +c .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg .. +c phi est un argum. de sortie pour le s-pg . +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + +c Arguments: +c ---------- + + INTEGER ngrid + REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) , + * phi(ngrid,llm) + + +c Local: +c ------ + + INTEGER l, ij + + +c----------------------------------------------------------------------- +c calcul de phi au niveau 1 pres du sol ..... + + DO 1 ij = 1, ngrid + phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) ) + 1 CONTINUE + +c calcul de phi aux niveaux superieurs ....... + + DO l = 2,llm + DO ij = 1,ngrid + phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l) + teta(ij,l-1) ) + * * ( pk(ij,l-1) - pk(ij,l) ) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/geopot_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/geopot_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/geopot_loc.F (revision 1632) @@ -0,0 +1,66 @@ + SUBROUTINE geopot_loc ( ngrid, teta, pk, pks, phis, phi ) + USE parallel + IMPLICIT NONE + + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul du geopotentiel aux milieux des couches ..... +c ******************************************************************* +c +c .... l'integration se fait de bas en haut .... +c +c .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg .. +c phi est un argum. de sortie pour le s-pg . +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + +c Arguments: +c ---------- + INTEGER ngrid + REAL teta(ijb_u:ije_u,llm),pks(ijb_u:ije_u),phis(ijb_u:ije_u), + * pk(ijb_u:ije_u,llm) , phi(ijb_u:ije_u,llm) + + +c Local: +c ------ + + INTEGER l, ij,ijb,ije + + +c----------------------------------------------------------------------- +c calcul de phi au niveau 1 pres du sol ..... + ijb=ij_begin + ije=ij_end+iip1 + + IF (pole_sud) ije=ij_end + + DO ij = ijb, ije + phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) ) + ENDDO + +c calcul de phi aux niveaux superieurs ....... + + DO l = 2,llm + DO ij = ijb,ije + phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l) + teta(ij,l-1) ) + * * ( pk(ij,l-1) - pk(ij,l) ) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/geopot_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/geopot_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/geopot_p.F (revision 1632) @@ -0,0 +1,66 @@ + SUBROUTINE geopot_p ( ngrid, teta, pk, pks, phis, phi ) + USE parallel + IMPLICIT NONE + + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul du geopotentiel aux milieux des couches ..... +c ******************************************************************* +c +c .... l'integration se fait de bas en haut .... +c +c .. ngrid,teta,pk,pks,phis sont des argum. d'entree pour le s-pg .. +c phi est un argum. de sortie pour le s-pg . +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + +c Arguments: +c ---------- + INTEGER ngrid + REAL teta(ngrid,llm),pks(ngrid),phis(ngrid),pk(ngrid,llm) , + * phi(ngrid,llm) + + +c Local: +c ------ + + INTEGER l, ij,ijb,ije + + +c----------------------------------------------------------------------- +c calcul de phi au niveau 1 pres du sol ..... + ijb=ij_begin + ije=ij_end+iip1 + + IF (pole_sud) ije=ij_end + + DO ij = ijb, ije + phi( ij,1 ) = phis( ij ) + teta(ij,1) * ( pks(ij) - pk(ij,1) ) + ENDDO + +c calcul de phi aux niveaux superieurs ....... + + DO l = 2,llm + DO ij = ijb,ije + phi(ij,l) = phi(ij,l-1) + 0.5 * ( teta(ij,l) + teta(ij,l-1) ) + * * ( pk(ij,l-1) - pk(ij,l) ) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/getparam.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/getparam.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/getparam.F90 (revision 1632) @@ -0,0 +1,118 @@ +! +! $Id: getparam.F90 1279 2009-12-10 09:02:56Z fairhead $ +! +MODULE getparam +#ifdef CPP_IOIPSL + USE IOIPSL +#else +! if not using IOIPSL, we still need to use (a local version of) getin + USE ioipsl_getincom +#endif + + INTERFACE getpar + MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml + END INTERFACE + + INTEGER, PARAMETER :: out_eff=99 + +CONTAINS + SUBROUTINE ini_getparam(fichier) + USE parallel + ! + IMPLICIT NONE + ! + CHARACTER*(*) :: fichier + IF (mpi_rank==0) OPEN(out_eff,file=fichier,status='unknown',form='formatted') + + END SUBROUTINE ini_getparam + + SUBROUTINE fin_getparam + USE parallel + ! + IMPLICIT NONE + ! + IF (mpi_rank==0) CLOSE(out_eff) + + END SUBROUTINE fin_getparam + + SUBROUTINE getparamr(TARGET,def_val,ret_val,comment) + USE parallel + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + REAL :: def_val + REAL :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + IF (mpi_rank==0) THEN + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) TARGET,'=',ret_val + ENDIF + + END SUBROUTINE getparamr + + SUBROUTINE getparami(TARGET,def_val,ret_val,comment) + USE parallel + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + INTEGER :: def_val + INTEGER :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + IF (mpi_rank==0) THEN + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) comment + write(out_eff,*) TARGET,'=',ret_val + ENDIF + + END SUBROUTINE getparami + + SUBROUTINE getparaml(TARGET,def_val,ret_val,comment) + USE parallel + ! + IMPLICIT NONE + ! + ! Get a real scalar. We first check if we find it + ! in the database and if not we get it from the run.def + ! + ! getinr1d and getinr2d are written on the same pattern + ! + CHARACTER*(*) :: TARGET + LOGICAL :: def_val + LOGICAL :: ret_val + CHARACTER*(*) :: comment + + ret_val=def_val + call getin(TARGET,ret_val) + + IF (mpi_rank==0) THEN + write(out_eff,*) '######################################' + write(out_eff,*) '#### ',comment,' #####' + write(out_eff,*) TARGET,'=',ret_val + ENDIF + + END SUBROUTINE getparaml + + +END MODULE getparam Index: /LMDZ5/trunk/libf/dyn3dmem/gr_dyn_fi.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_dyn_fi.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_dyn_fi.F (revision 1632) @@ -0,0 +1,38 @@ +! +! $Header$ +! + SUBROUTINE gr_dyn_fi(nfield,im,jm,ngrid,pdyn,pfi) + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- + + IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim' +c traitement des poles + CALL SCOPY(nfield,pdyn,im*jm,pfi,ngrid) + CALL SCOPY(nfield,pdyn(1,jm,1),im*jm,pfi(ngrid,1),ngrid) + +c traitement des point normaux + DO ifield=1,nfield + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pdyn(1,j,ifield),1,pfi(ig,ifield),1) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gr_dyn_fi_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_dyn_fi_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_dyn_fi_p.F (revision 1632) @@ -0,0 +1,49 @@ +! +! $Id: gr_dyn_fi_p.F 1279 2009-12-10 09:02:56Z fairhead $ +! + SUBROUTINE gr_dyn_fi_p(nfield,im,jm,ngrid,pdyn,pfi) +#ifdef CPP_EARTH +! Interface with parallel physics, +! for now this routine only works with Earth physics + USE mod_interface_dyn_phys + USE dimphy + USE PARALLEL + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ig,l + +c----------------------------------------------------------------------- +c calcul: +c ------- + +c IF(ngrid.NE.2+(jm-2)*(im-1)) STOP 'probleme de dim' +c traitement des poles +c traitement des point normaux +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nfield + DO ig=1,klon + i=index_i(ig) + j=index_j(ig) + pfi(ig,l)=pdyn(i,j,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +#else + write(lunout,*) "gr_fi_dyn_p : This routine should not be called", + & "without parallelized physics" + stop +#endif +! of #ifdef CPP_EARTH + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gr_ecrit_fi.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_ecrit_fi.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_ecrit_fi.F (revision 1632) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE gr_ecrit_fi(nfield,nlon,iim,jjmp1,ecrit,fi) + + IMPLICIT none + +c Transformer une variable de la grille d'ecriture a la grille physique + + INTEGER nfield,nlon,iim,jjmp1, jjm + REAL fi(nlon,nfield), ecrit(iim,jjmp1,nfield) +c + INTEGER i, j, n, ig +c +c print*,'iim jjm ',iim,jjm + +c modif par abd 21 02 01 + + jjm = jjmp1 - 1 + do n = 1, nfield + fi(1,n) = ecrit(1,1,n) + fi(nlon,n) = ecrit(1,jjm+1,n) + DO j = 2, jjm + ig = 2+(j-2)*iim + DO i = 1, iim + fi(ig-1+i,n) = ecrit(i,j,n) + ENDDO + ENDDO + ENDDO + RETURN + END + Index: /LMDZ5/trunk/libf/dyn3dmem/gr_fi_dyn.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_fi_dyn.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_fi_dyn.F (revision 1632) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn) + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- + + DO ifield=1,nfield +c traitement des poles + DO i=1,im + pdyn(i,1,ifield)=pfi(1,ifield) + pdyn(i,jm,ifield)=pfi(ngrid,ifield) + ENDDO + +c traitement des point normaux + DO j=2,jm-1 + ig=2+(j-2)*(im-1) + CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1) + pdyn(im,j,ifield)=pdyn(1,j,ifield) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gr_fi_dyn_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_fi_dyn_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_fi_dyn_p.F (revision 1632) @@ -0,0 +1,61 @@ +! +! $Id: gr_fi_dyn_p.F 1279 2009-12-10 09:02:56Z fairhead $ +! + SUBROUTINE gr_fi_dyn_p(nfield,ngrid,im,jm,pfi,pdyn) +#ifdef CPP_EARTH +! Interface with parallel physics, +! for now this routine only works with Earth physics + USE mod_interface_dyn_phys + USE dimphy + use parallel + IMPLICIT NONE +c======================================================================= +c passage d'un champ de la grille scalaire a la grille physique +c======================================================================= + +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER im,jm,ngrid,nfield + REAL pdyn(im,jm,nfield) + REAL pfi(ngrid,nfield) + + INTEGER i,j,ifield,ig + +c----------------------------------------------------------------------- +c calcul: +c ------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO ifield=1,nfield + + do ig=1,klon + i=index_i(ig) + j=index_j(ig) + pdyn(i,j,ifield)=pfi(ig,ifield) + if (i==1) pdyn(im,j,ifield)=pdyn(i,j,ifield) + enddo + +c traitement des poles + if (pole_nord) then + do i=1,im + pdyn(i,1,ifield)=pdyn(1,1,ifield) + enddo + endif + + if (pole_sud) then + do i=1,im + pdyn(i,jm,ifield)=pdyn(1,jm,ifield) + enddo + endif + + ENDDO +c$OMP END DO NOWAIT +#else + write(lunout,*) "gr_fi_dyn_p : This routine should not be called", + & "without parallelized physics" + stop +#endif +! of #ifdef CPP_EARTH + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gr_int_dyn.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_int_dyn.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_int_dyn.F (revision 1632) @@ -0,0 +1,49 @@ +! +! $Header$ +! + subroutine gr_int_dyn(champin,champdyn,iim,jp1) + implicit none +c======================================================================= +c passage d'un champ interpole a un champ sur grille scalaire +c======================================================================= +c----------------------------------------------------------------------- +c declarations: +c ------------- + + INTEGER iim + integer ip1, jp1 + REAL champin(iim, jp1) + REAL champdyn(iim+1, jp1) + + INTEGER i, j + real polenord, polesud + +c----------------------------------------------------------------------- +c calcul: +c ------- + + ip1 = iim + 1 + polenord = 0. + polesud = 0. + do i = 1, iim + polenord = polenord + champin (i, 1) + polesud = polesud + champin (i, jp1) + enddo + polenord = polenord / iim + polesud = polesud / iim + do j = 1, jp1 + do i = 1, iim + if (j .eq. 1) then + champdyn(i, j) = polenord + else if (j .eq. jp1) then + champdyn(i, j) = polesud + else + champdyn(i, j) = champin (i, j) + endif + enddo + champdyn(ip1, j) = champdyn(1, j) + enddo + + RETURN + END + Index: /LMDZ5/trunk/libf/dyn3dmem/gr_u_scal.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_u_scal.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_u_scal.F (revision 1632) @@ -0,0 +1,60 @@ +! +! $Header$ +! + SUBROUTINE gr_u_scal(nx,x_u,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + +c----------------------------------------------------------------------- + + DO l=1,nx + DO ij=ip1jmp1,2,-1 + x_scal(ij,l)= + s (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) + s /(aireu(ij)+aireu(ij-1)) + ENDDO + ENDDO + + CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gr_u_scal_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_u_scal_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_u_scal_loc.F (revision 1632) @@ -0,0 +1,75 @@ +! +! $Header$ +! + SUBROUTINE gr_u_scal_loc(nx,x_u,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + USE parallel + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_u(ijb_u:ije_u,nx),x_scal(ijb_u:ije_u,nx) + +c Local: +c ------ + + INTEGER l,ij + INTEGER :: ijb,ije + +c----------------------------------------------------------------------- + ijb=ij_begin + ije=ij_end + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nx + DO ij=ijb+1,ije + x_scal(ij,l)= + s (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) + s /(aireu(ij)+aireu(ij-1)) + ENDDO + ENDDO +!$OMP ENDDO NOWAIT + + ijb=ij_begin + ije=ij_end + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nx + DO ij=ijb,ije-iip1+1,iip1 + x_scal(ij,l)=x_scal(ij+iip1-1,l) + ENDDO + ENDDO +!$OMP ENDDO NOWAIT + RETURN + + END Index: /LMDZ5/trunk/libf/dyn3dmem/gr_u_scal_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_u_scal_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_u_scal_p.F (revision 1632) @@ -0,0 +1,72 @@ +! +! $Header$ +! + SUBROUTINE gr_u_scal_p(nx,x_u,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + USE parallel + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_u(ip1jmp1,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + INTEGER :: ijb,ije + +c----------------------------------------------------------------------- + ijb=ij_begin + ije=ij_end + + DO l=1,nx + DO ij=ijb+1,ije + x_scal(ij,l)= + s (aireu(ij)*x_u(ij,l)+aireu(ij-1)*x_u(ij-1,l)) + s /(aireu(ij)+aireu(ij-1)) + ENDDO + ENDDO + +cym CALL SCOPY(nx*jjp1,x_scal(iip1,1),iip1,x_scal(1,1),iip1) + ijb=ij_begin + ije=ij_end + + DO l=1,nx + DO ij=ijb,ije-iip1+1,iip1 + x_scal(ij,l)=x_scal(ij+iip1-1,l) + ENDDO + ENDDO + RETURN + + END Index: /LMDZ5/trunk/libf/dyn3dmem/gr_v_scal.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_v_scal.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_v_scal.F (revision 1632) @@ -0,0 +1,64 @@ +! +! $Header$ +! + SUBROUTINE gr_v_scal(nx,x_v,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + +c----------------------------------------------------------------------- + + DO l=1,nx + DO ij=iip2,ip1jm + x_scal(ij,l)= + s (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) + s /(airev(ij-iip1)+airev(ij)) + ENDDO + DO ij=1,iip1 + x_scal(ij,l)=0. + ENDDO + DO ij=ip1jm+1,ip1jmp1 + x_scal(ij,l)=0. + ENDDO + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gr_v_scal_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_v_scal_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_v_scal_loc.F (revision 1632) @@ -0,0 +1,85 @@ +! +! $Header$ +! + SUBROUTINE gr_v_scal_loc(nx,x_v,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + USE parallel + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_v(ijb_v:ije_v,nx),x_scal(ijb_v:ije_v,nx) + +c Local: +c ------ + + INTEGER l,ij + INTEGER :: ijb,ije +c----------------------------------------------------------------------- + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nx + DO ij=ijb,ije + x_scal(ij,l)= + s (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) + s /(airev(ij-iip1)+airev(ij)) + ENDDO + ENDDO +!$OMP ENDDO NOWAIT + + if (pole_nord) then +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nx + DO ij=1,iip1 + x_scal(ij,l)=0. + ENDDO + ENDDO +!$OMP ENDDO NOWAIT + endif + + if (pole_sud) then +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nx + DO ij=ip1jm+1,ip1jmp1 + x_scal(ij,l)=0. + ENDDO + ENDDO +!$OMP ENDDO NOWAIT + endif + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gr_v_scal_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gr_v_scal_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gr_v_scal_p.F (revision 1632) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE gr_v_scal_p(nx,x_v,x_scal) +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 11/11/92 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + USE parallel + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c Arguments: +c ---------- + + INTEGER nx + REAL x_v(ip1jm,nx),x_scal(ip1jmp1,nx) + +c Local: +c ------ + + INTEGER l,ij + INTEGER :: ijb,ije +c----------------------------------------------------------------------- + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO l=1,nx + DO ij=ijb,ije + x_scal(ij,l)= + s (airev(ij-iip1)*x_v(ij-iip1,l)+airev(ij)*x_v(ij,l)) + s /(airev(ij-iip1)+airev(ij)) + ENDDO + ENDDO + + if (pole_nord) then + DO l=1,nx + DO ij=1,iip1 + x_scal(ij,l)=0. + ENDDO + ENDDO + endif + + if (pole_sud) then + DO l=1,nx + DO ij=ip1jm+1,ip1jmp1 + x_scal(ij,l)=0. + ENDDO + ENDDO + endif + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/grad.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/grad.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/grad.F (revision 1632) @@ -0,0 +1,44 @@ +! +! $Header$ +! + SUBROUTINE grad(klevel, pg,pgx,pgy ) +c +c P. Le Van +c +c ****************************************************************** +c .. calcul des composantes covariantes en x et y du gradient de g +c +c ****************************************************************** +c pg est un argument d'entree pour le s-prog +c pgx et pgy sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + INTEGER klevel + REAL pg( ip1jmp1,klevel ) + REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel ) + INTEGER l,ij +c +c + DO 6 l = 1,klevel +c + DO 2 ij = 1, ip1jmp1 - 1 + pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) + 2 CONTINUE +c +c .... correction pour pgx(ip1,j,l) .... +c ... pgx(iip1,j,l)= pgx(1,j,l) .... +CDIR$ IVDEP + DO 3 ij = iip1, ip1jmp1, iip1 + pgx( ij,l ) = pgx( ij -iim,l ) + 3 CONTINUE +c + DO 4 ij = 1,ip1jm + pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) + 4 CONTINUE +c + 6 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/grad_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/grad_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/grad_loc.F (revision 1632) @@ -0,0 +1,53 @@ + SUBROUTINE grad_loc(klevel, pg,pgx,pgy ) +c +c P. Le Van +c +c ****************************************************************** +c .. calcul des composantes covariantes en x et y du gradient de g +c +c ****************************************************************** +c pg est un argument d'entree pour le s-prog +c pgx et pgy sont des arguments de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + INTEGER klevel + REAL pg( ijb_u:ije_u,klevel ) + REAL pgx( ijb_u:ije_u,klevel ) , pgy( ijb_v:ije_v,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije,jjb,jje +c +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 6 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + DO 2 ij = ijb, ije - 1 + pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) + 2 CONTINUE +c +c .... correction pour pgx(ip1,j,l) .... +c ... pgx(iip1,j,l)= pgx(1,j,l) .... +CDIR$ IVDEP + DO 3 ij = ijb+iip1-1, ije, iip1 + pgx( ij,l ) = pgx( ij -iim,l ) + 3 CONTINUE +c + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) + 4 CONTINUE +c + 6 CONTINUE +c$OMP END DO NOWAIT + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/grad_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/grad_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/grad_p.F (revision 1632) @@ -0,0 +1,53 @@ + SUBROUTINE grad_p(klevel, pg,pgx,pgy ) +c +c P. Le Van +c +c ****************************************************************** +c .. calcul des composantes covariantes en x et y du gradient de g +c +c ****************************************************************** +c pg est un argument d'entree pour le s-prog +c pgx et pgy sont des arguments de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" + INTEGER klevel + REAL pg( ip1jmp1,klevel ) + REAL pgx( ip1jmp1,klevel ) , pgy( ip1jm,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije,jjb,jje +c +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 6 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + DO 2 ij = ijb, ije - 1 + pgx( ij,l ) = pg( ij +1,l ) - pg( ij,l ) + 2 CONTINUE +c +c .... correction pour pgx(ip1,j,l) .... +c ... pgx(iip1,j,l)= pgx(1,j,l) .... +CDIR$ IVDEP + DO 3 ij = ijb+iip1-1, ije, iip1 + pgx( ij,l ) = pgx( ij -iim,l ) + 3 CONTINUE +c + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + pgy( ij,l ) = pg( ij,l ) - pg( ij +iip1,l ) + 4 CONTINUE +c + 6 CONTINUE +c$OMP END DO NOWAIT + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gradiv.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gradiv.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gradiv.F (revision 1632) @@ -0,0 +1,57 @@ +! +! $Header$ +! + SUBROUTINE gradiv(klevel, xcov, ycov, ld, gdx, gdy ) +c +c Auteur : P. Le Van +c +c *************************************************************** +c +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c **************************************************************** +c xcov , ycov et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" + + INTEGER klevel +c + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) + + REAL div(ip1jmp1,llm) + + INTEGER l,ij,iter,ld +c +c +c + CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 ) + CALL SCOPY( ip1jm*klevel, ycov,1,gdy,1 ) +c + DO 10 iter = 1,ld +c + CALL diverg( klevel, gdx , gdy, div ) + CALL filtreg( div, jjp1, klevel, 2,1, .true.,2 ) + CALL grad( klevel, div, gdx, gdy ) +c + DO 5 l = 1, klevel + DO 3 ij = 1, ip1jmp1 + gdx( ij,l ) = - gdx( ij,l ) * cdivu + 3 CONTINUE + DO 4 ij = 1, ip1jm + gdy( ij,l ) = - gdy( ij,l ) * cdivu + 4 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gradiv2.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gradiv2.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gradiv2.F (revision 1632) @@ -0,0 +1,79 @@ +! +! $Header$ +! + SUBROUTINE gradiv2(klevel, xcov, ycov, ld, gdx, gdy ) +c +c P. Le Van +c +c ********************************************************** +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c ********************************************************** +c xcont , ycont et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +c +c ........ variables en arguments ........ + + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL gdx( ip1jmp1,klevel ), gdy( ip1jm,klevel ) +c +c ........ variables locales ......... +c + REAL div(ip1jmp1,llm) + REAL signe, nugrads + INTEGER l,ij,iter,ld + +c ........................................................ +c +c + CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 ) + CALL SCOPY( ip1jm * klevel, ycov, 1, gdy, 1 ) +c +c + signe = (-1.)**ld + nugrads = signe * cdivu +c + + + CALL divergf( klevel, gdx, gdy , div ) + + IF( ld.GT.1 ) THEN + + CALL laplacien ( klevel, div, div ) + +c ...... Iteration de l'operateur laplacien_gam ....... + + DO iter = 1, ld -2 + CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1, + * unsapolnga1, unsapolsga1, div, div ) + ENDDO + + ENDIF + + + CALL filtreg( div , jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad ( klevel, div, gdx, gdy ) + +c + DO l = 1, klevel + DO ij = 1, ip1jmp1 + gdx( ij,l ) = gdx( ij,l ) * nugrads + ENDDO + DO ij = 1, ip1jm + gdy( ij,l ) = gdy( ij,l ) * nugrads + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gradiv2_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gradiv2_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gradiv2_loc.F (revision 1632) @@ -0,0 +1,149 @@ + SUBROUTINE gradiv2_loc(klevel, xcov, ycov, ld, gdx_out, gdy_out ) +c +c P. Le Van +c +c ********************************************************** +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c ********************************************************** +c xcont , ycont et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + USE parallel + USE times + USE Write_field_p + USE mod_hallo + USE mod_filtreg_p + USE gradiv2_mod + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +c +c ........ variables en arguments ........ + + INTEGER klevel + REAL xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel ) + REAL gdx_out( ijb_u:ije_u,klevel ), gdy_out( ijb_v:ije_v,klevel) +c +c ........ variables locales ......... +c + REAL :: tmp_div2(ijb_u:ije_u,llm) + REAL signe, nugrads + INTEGER l,ij,iter,ld + INTEGER :: ijb,ije,jjb,jje + Type(Request) :: request_dissip + +c ........................................................ +c +c +c CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 ) +c CALL SCOPY( ip1jm * klevel, ycov, 1, gdy, 1 ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gdx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gdy(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER + call Register_Hallo_v(gdy,llm,1,0,0,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER +c +c + signe = (-1.)**ld + nugrads = signe * cdivu +c + + + CALL divergf_loc( klevel, gdx, gdy , div ) +c call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/))) + + IF( ld.GT.1 ) THEN +c$OMP BARRIER + call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + CALL laplacien_loc( klevel, div, div ) + +c ...... Iteration de l'operateur laplacien_gam ....... +c call write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/))) + + DO iter = 1, ld -2 +c$OMP BARRIER + call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + CALL laplacien_gam_loc(klevel,cuvscvgam1,cvuscugam1, + & unsair_gam1,unsapolnga1, unsapolsga1, + & div, div ) + ENDDO +c call write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/))) + ENDIF + + jjb=jj_begin + jje=jj_end + + CALL filtreg_p( div ,jjb_u,jje_u,jjb,jje, jjp1, + & klevel, 2, 1, .TRUE., 1 ) +c call exchange_Hallo(div,ip1jmp1,llm,0,1) +c$OMP BARRIER + call Register_Hallo_u(div,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + + CALL grad_loc( klevel, div, gdx, gdy ) + +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + + if (pole_sud) ije=ij_end + DO ij = ijb, ije + gdx_out( ij,l ) = gdx( ij,l ) * nugrads + ENDDO + + if (pole_sud) ije=ij_end-iip1 + DO ij = ijb, ije + gdy_out( ij,l ) = gdy( ij,l ) * nugrads + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gradiv2_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gradiv2_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gradiv2_mod.F90 (revision 1632) @@ -0,0 +1,39 @@ +MODULE gradiv2_mod + + REAL,POINTER,SAVE :: gdx( :,: ) + REAL,POINTER,SAVE :: gdy( :,: ) + REAL,POINTER,SAVE :: div( :,: ) + +CONTAINS + + SUBROUTINE gradiv2_allocate + USE bands + USE allocate_field + USE parallel + USE dimensions + IMPLICIT NONE + TYPE(distrib),POINTER :: d + d=>distrib_dissip + + CALL allocate_u(gdx,llm,d) + CALL allocate_v(gdy,llm,d) + CALL allocate_u(div,llm,d) + + + END SUBROUTINE gradiv2_allocate + + SUBROUTINE gradiv2_switch_dissip(dist) + USE allocate_field + USE bands + USE parallel + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(gdx,distrib_dissip,dist) + CALL switch_v(gdy,distrib_dissip,dist) + CALL switch_u(div,distrib_dissip,dist) + + + END SUBROUTINE gradiv2_switch_dissip + +END MODULE gradiv2_mod Index: /LMDZ5/trunk/libf/dyn3dmem/gradiv2_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gradiv2_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gradiv2_p.F (revision 1632) @@ -0,0 +1,147 @@ + SUBROUTINE gradiv2_p(klevel, xcov, ycov, ld, gdx_out, gdy_out ) +c +c P. Le Van +c +c ********************************************************** +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c ********************************************************** +c xcont , ycont et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + USE parallel + USE times + USE Write_field_p + USE mod_hallo + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "comdissipn.h" +c +c ........ variables en arguments ........ + + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL,SAVE :: gdx( ip1jmp1,llm ), gdy( ip1jm,llm ) + REAL gdx_out( ip1jmp1,klevel ), gdy_out( ip1jm,klevel ) +c +c ........ variables locales ......... +c + REAL,SAVE :: div(ip1jmp1,llm) + REAL :: tmp_div2(ip1jmp1,llm) + REAL signe, nugrads + INTEGER l,ij,iter,ld + INTEGER :: ijb,ije,jjb,jje + Type(Request) :: request_dissip + +c ........................................................ +c +c +c CALL SCOPY( ip1jmp1 * klevel, xcov, 1, gdx, 1 ) +c CALL SCOPY( ip1jm * klevel, ycov, 1, gdy, 1 ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gdx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gdy(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER + call Register_Hallo(gdy,ip1jm,llm,1,0,0,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER +c +c + signe = (-1.)**ld + nugrads = signe * cdivu +c + + + CALL divergf_p( klevel, gdx, gdy , div ) +c call write_field3d_p('div1',reshape(div,(/iip1,jjp1,llm/))) + + IF( ld.GT.1 ) THEN +c$OMP BARRIER + call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + CALL laplacien_p ( klevel, div, div ) + +c ...... Iteration de l'operateur laplacien_gam ....... +c call write_field3d_p('div2',reshape(div,(/iip1,jjp1,llm/))) + + DO iter = 1, ld -2 +c$OMP BARRIER + call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + CALL laplacien_gam ( klevel,cuvscvgam1,cvuscugam1,unsair_gam1, + * unsapolnga1, unsapolsga1, div, div ) + ENDDO +c call write_field3d_p('div3',reshape(div,(/iip1,jjp1,llm/))) + ENDIF + + jjb=jj_begin + jje=jj_end + + CALL filtreg_p( div ,jjb,jje, jjp1, klevel, 2, 1, .TRUE., 1 ) +c call exchange_Hallo(div,ip1jmp1,llm,0,1) +c$OMP BARRIER + call Register_Hallo(div,ip1jmp1,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) + +c$OMP BARRIER + + + CALL grad_p ( klevel, div, gdx, gdy ) + +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + + if (pole_sud) ije=ij_end + DO ij = ijb, ije + gdx_out( ij,l ) = gdx( ij,l ) * nugrads + ENDDO + + if (pole_sud) ije=ij_end-iip1 + DO ij = ijb, ije + gdy_out( ij,l ) = gdy( ij,l ) * nugrads + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gradiv_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gradiv_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gradiv_p.F (revision 1632) @@ -0,0 +1,109 @@ + SUBROUTINE gradiv_p(klevel, xcov, ycov, ld, gdx_out, gdy_out ) +c +c Auteur : P. Le Van +c +c *************************************************************** +c +c ld +c calcul de (grad (div) ) du vect. v .... +c +c xcov et ycov etant les composant.covariantes de v +c **************************************************************** +c xcov , ycov et ld sont des arguments d'entree pour le s-prog +c gdx et gdy sont des arguments de sortie pour le s-prog +c +c + USE parallel + USE times + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" + + INTEGER klevel +c + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL,SAVE :: gdx( ip1jmp1,llm ), gdy( ip1jm,llm ) + + REAL gdx_out( ip1jmp1,klevel ), gdy_out( ip1jm,klevel ) + + REAL,SAVE :: div(ip1jmp1,llm) + + INTEGER l,ij,iter,ld +c + INTEGER ijb,ije,jjb,jje +c +c +c CALL SCOPY( ip1jmp1*klevel,xcov,1,gdx,1 ) +c CALL SCOPY( ip1jm*klevel, ycov,1,gdy,1 ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + gdx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,klevel + gdy(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c + DO 10 iter = 1,ld + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(gdy,ip1jm,llm,1,0) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL diverg_p( klevel, gdx , gdy, div ) + + jjb=jj_begin + jje=jj_end + CALL filtreg_p( div,jjb,jje, jjp1, klevel, 2,1, .true.,2 ) + +c call exchange_Hallo(div,ip1jmp1,llm,0,1) + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(div,ip1jmp1,llm,1,1) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL grad_p( klevel, div, gdx, gdy ) +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1, klevel + + if(pole_sud) ije=ij_end + DO 3 ij = ijb, ije + gdx_out( ij,l ) = - gdx( ij,l ) * cdivu + 3 CONTINUE + + if(pole_sud) ije=ij_end-iip1 + DO 4 ij = ijb, ije + gdy_out( ij,l ) = - gdy( ij,l ) * cdivu + 4 CONTINUE + + 5 CONTINUE +c$OMP END DO NOWAIT +c + 10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/gradsdef.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/gradsdef.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/gradsdef.h (revision 1632) @@ -0,0 +1,23 @@ +! +! $Header$ +! + integer nfmx,imx,jmx,lmx,nvarmx + parameter(nfmx=10,imx=200,jmx=150,lmx=200,nvarmx=1000) + + real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx) + + integer imd(imx),jmd(jmx),lmd(lmx) + integer iid(imx),jid(jmx) + integer ifd(imx),jfd(jmx) + integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx) + + integer nvar(nfmx),ivar(nfmx) + logical firsttime(nfmx) + + character*10 var(nvarmx,nfmx),fichier(nfmx) + character*40 title(nfmx),tvar(nvarmx,nfmx) + + common/gradsdef/xd,yd,zd,dtime, + s imd,jmd,lmd,iid,jid,ifd,jfd, + s unit,irec,nvar,ivar,itime,nld,firsttime, + s var,fichier,title,tvar Index: /LMDZ5/trunk/libf/dyn3dmem/grid_atob.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/grid_atob.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/grid_atob.F (revision 1632) @@ -0,0 +1,971 @@ +! +! $Id: grid_atob.F 1299 2010-01-20 14:27:21Z fairhead $ +! + SUBROUTINE grille_m(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie) +c======================================================================= +c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead) +c +c Methode naive pour transformer un champ d'une grille fine a une +c grille grossiere. Je considere que les nouveaux points occupent +c une zone adjacente qui comprend un ou plusieurs anciens points +c +c Aucune ponderation est consideree (voir grille_p) +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X et Y pour depart +c xdata, ydata: coordonnees X et Y pour depart +c entree: champ d'entree a transformer +c OUTPUT: +c imar, jmar: dimensions X et Y d'arrivee +c x, y: coordonnees X et Y d'arrivee +c sortie: champ de sortie deja transforme +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL number(2200,1100) + REAL distans(2200*1100) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c +c Calculer les limites des zones des nouveaux points +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO +c +c Determiner la zone sur laquelle chaque ancien point se trouve +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + sortie(ii,jj) = sortie(ii,jj) + entree(i,j) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c Si aucun ancien point tombe sur une zone, c'est un probleme +c + + DO i = 1, imar + DO j = 1, jmar + IF (number(i,j) .GT. 0.001) THEN + sortie(i,j) = sortie(i,j) / number(i,j) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + sortie(i,j) = entree(i_proche,j_proche) + ENDIF + ENDDO + ENDDO + + RETURN + END + + + SUBROUTINE grille_p(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie) +c======================================================================= +c z.x.li (le 1 avril 1994) (voir aussi A. Harzallah et L. Fairhead) +c +c Methode naive pour transformer un champ d'une grille fine a une +c grille grossiere. Je considere que les nouveaux points occupent +c une zone adjacente qui comprend un ou plusieurs anciens points +c +c Consideration de la distance des points (voir grille_m) +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X et Y pour depart +c xdata, ydata: coordonnees X et Y pour depart +c entree: champ d'entree a transformer +c OUTPUT: +c imar, jmar: dimensions X et Y d'arrivee +c x, y: coordonnees X et Y d'arrivee +c sortie: champ de sortie deja transforme +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(200),d(200) + REAL number(400,200) + INTEGER indx(400,200), indy(400,200) + REAL dist(400,200), distsom(400,200) +c + IF (imar.GT.400 .OR. jmar.GT.200) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + IF (imdep.GT.400 .OR. jmdep.GT.200) THEN + PRINT*, 'imdep ou jmdep trop grand', imdep, jmdep + CALL ABORT + ENDIF +c +c calculer les bords a et b de la nouvelle grille +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + +c +c calculer les bords c et d de la nouvelle grille +c + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + +c +c trouver les indices (indx,indy) de la nouvelle grille sur laquelle +c un point de l'ancienne grille est tombe. +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + indx(i,j) = ii + indy(i,j) = jj + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c faire une verification +c + + DO i = 1, imdep + DO j = 1, jmdep + IF (indx(i,j).GT.imar .OR. indy(i,j).GT.jmar) THEN + PRINT*, 'Probleme grave,i,j,indx,indy=', + . i,j,indx(i,j),indy(i,j) + CALL abort + ENDIF + ENDDO + ENDDO + +c +c calculer la distance des anciens points avec le nouveau point, +c on prend ensuite une sorte d'inverse pour ponderation. +c + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + distsom(i,j) = 0.0 + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + dist(i,j) = SQRT ( (xdata(i)-x(indx(i,j)))**2 + . +(ydata(j)-y(indy(i,j)))**2 ) + distsom(indx(i,j),indy(i,j)) = distsom(indx(i,j),indy(i,j)) + . + dist(i,j) + number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) +1. + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + dist(i,j) = 1.0 - dist(i,j)/distsom(indx(i,j),indy(i,j)) + ENDDO + ENDDO + + DO i = 1, imar + DO j = 1, jmar + number(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO + DO i = 1, imdep + DO j = 1, jmdep + sortie(indx(i,j),indy(i,j)) = sortie(indx(i,j),indy(i,j)) + . + entree(i,j) * dist(i,j) + number(indx(i,j),indy(i,j)) = number(indx(i,j),indy(i,j)) + . + dist(i,j) + ENDDO + ENDDO + DO i = 1, imar + DO j = 1, jmar + IF (number(i,j) .GT. 0.001) THEN + sortie(i,j) = sortie(i,j) / number(i,j) + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + + SUBROUTINE mask_c_o(imdep, jmdep, xdata, ydata, relief, + . imar, jmar, x, y, mask) +c======================================================================= +c z.x.li (le 1 avril 1994): A partir du champ de relief, on fabrique +c un champ indicateur (masque) terre/ocean +c terre:1; ocean:0 +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL relief(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL mask(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL num_tot(2200,1100), num_oce(2200,1100) +c + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_oce(i,j) = 0.0 + num_tot(i,j) = 0.0 + ENDDO + ENDDO + +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + IF (.NOT. ( relief(i,j) - 0.9. GE. 1.e-5 ) ) + . num_oce(ii,jj) = num_oce(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c +c + DO i = 1, imar + DO j = 1, jmar + IF (num_tot(i,j) .GT. 0.001) THEN + IF ( num_oce(i,j)/num_tot(i,j) - 0.5 .GE. 1.e-5 ) THEN + mask(i,j) = 0. + ELSE + mask(i,j) = 1. + ENDIF + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO + + RETURN + END +c +c + + + SUBROUTINE rugosite(imdep, jmdep, xdata, ydata, entree, + . imar, jmar, x, y, sortie, mask) +c======================================================================= +c z.x.li (le 1 avril 1994): Transformer la longueur de rugosite d'une +c grille fine a une grille grossiere. Sur l'ocean, on impose une valeur +c fixe (0.001m). +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL entree(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL sortie(imar,jmar), mask(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(400),d(400) + REAL num_tot(400,400) + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.400 .OR. jmar.GT.400) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_tot(i,j) = 0.0 + sortie(i,j) = 0.0 + ENDDO + ENDDO + +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + sortie(ii,jj) = sortie(ii,jj) + LOG(entree(i,j)) + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c + + DO i = 1, imar + DO j = 1, jmar + IF (NINT(mask(i,j)).EQ.1) THEN + IF (num_tot(i,j) .GT. 0.0) THEN + sortie(i,j) = sortie(i,j) / num_tot(i,j) + sortie(i,j) = EXP(sortie(i,j)) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + sortie(i,j) = entree(i_proche,j_proche) + ENDIF + ELSE + sortie(i,j) = 0.001 + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + + + SUBROUTINE sea_ice(imdep, jmdep, xdata, ydata, glace01, + . imar, jmar, x, y, frac_ice) +c======================================================================= +c z.x.li (le 1 avril 1994): Transformer un champ d'indicateur de la +c glace (1, sinon 0) d'une grille fine a un champ de fraction de glace +c (entre 0 et 1) dans une grille plus grossiere. +c +c Methode naive (voir grille_m) +C======================================================================= + IMPLICIT none + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL glace01(imdep,jmdep) +c + INTEGER imar, jmar + REAL x(imar),y(jmar) + REAL frac_ice(imar,jmar) +c + INTEGER i, j, ii, jj + REAL a(400),b(400),c(400),d(400) + REAL num_tot(400,400), num_ice(400,400) + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + IF (imar.GT.400 .OR. jmar.GT.400) THEN + PRINT*, 'imar ou jmar trop grand', imar, jmar + CALL ABORT + ENDIF +c + + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar-1 + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar) = b(imar-1) + b(imar) = x(imar) + (x(imar)-x(imar-1))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 + + DO i = 1, imar + DO j = 1, jmar + num_ice(i,j) = 0.0 + num_tot(i,j) = 0.0 + ENDDO + ENDDO + +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imar + DO jj = 1, jmar + DO i = 1, imdep + IF( ( xdata(i)-a(ii).GE.1.e-5.AND.xdata(i)-b(ii).LE.1.e-5 ).OR. + . ( xdata(i)-a(ii).LE.1.e-5.AND.xdata(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmdep + IF( (ydata(j)-c(jj).GE.1.e-5.AND.ydata(j)-d(jj).LE.1.e-5 ).OR. + . ( ydata(j)-c(jj).LE.1.e-5.AND.ydata(j)-d(jj).GE.1.e-5 ) ) + . THEN + num_tot(ii,jj) = num_tot(ii,jj) + 1.0 + IF (NINT(glace01(i,j)).EQ.1 ) + . num_ice(ii,jj) = num_ice(ii,jj) + 1.0 + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + + DO i = 1, imar + DO j = 1, jmar + IF (num_tot(i,j) .GT. 0.001) THEN + IF (num_ice(i,j).GT.0.001) THEN + frac_ice(i,j) = num_ice(i,j) / num_tot(i,j) + ELSE + frac_ice(i,j) = 0.0 + ENDIF + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(x(i),y(j),xdata,ydata,imdep,jmdep,distans) +#ifdef CRAY + ij_proche = ISMIN(imdep*jmdep,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imdep*jmdep + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imdep + 1 + i_proche = ij_proche - (j_proche-1)*imdep + PRINT*, "solution:", ij_proche, i_proche, j_proche + IF (NINT(glace01(i_proche,j_proche)).EQ.1 ) THEN + frac_ice(i,j) = 1.0 + ELSE + frac_ice(i,j) = 0.0 + ENDIF + ENDIF + ENDDO + ENDDO + + RETURN + END + + + + SUBROUTINE rugsoro(imrel, jmrel, xrel, yrel, relief, + . immod, jmmod, xmod, ymod, rugs) +c======================================================================= +c Calculer la longueur de rugosite liee au relief en utilisant +c l'ecart-type dans une maille de 1x1 +C======================================================================= + IMPLICIT none +c +#ifdef CRAY + INTEGER ISMIN +#else + REAL zzmin +#endif +c + REAL amin, AMAX +c + INTEGER imrel, jmrel + REAL xrel(imrel),yrel(jmrel) + REAL relief(imrel,jmrel) +c + INTEGER immod, jmmod + REAL xmod(immod),ymod(jmmod) + REAL rugs(immod,jmmod) +c + INTEGER imtmp, jmtmp + PARAMETER (imtmp=360,jmtmp=180) + REAL xtmp(imtmp), ytmp(jmtmp) + REAL(KIND=8) cham1tmp(imtmp,jmtmp), cham2tmp(imtmp,jmtmp) + REAL zzzz +c + INTEGER i, j, ii, jj + REAL a(2200),b(2200),c(1100),d(1100) + REAL number(2200,1100) +c + REAL distans(400*400) + INTEGER i_proche, j_proche, ij_proche +c + IF (immod.GT.2200 .OR. jmmod.GT.1100) THEN + PRINT*, 'immod ou jmmod trop grand', immod, jmmod + CALL ABORT + ENDIF +c +c Calculs intermediares: +c + xtmp(1) = -180.0 + 360.0/REAL(imtmp) / 2.0 + DO i = 2, imtmp + xtmp(i) = xtmp(i-1) + 360.0/REAL(imtmp) + ENDDO + DO i = 1, imtmp + xtmp(i) = xtmp(i) /180.0 * 4.0*ATAN(1.0) + ENDDO + ytmp(1) = -90.0 + 180.0/REAL(jmtmp) / 2.0 + DO j = 2, jmtmp + ytmp(j) = ytmp(j-1) + 180.0/REAL(jmtmp) + ENDDO + DO j = 1, jmtmp + ytmp(j) = ytmp(j) /180.0 * 4.0*ATAN(1.0) + ENDDO +c + a(1) = xtmp(1) - (xtmp(2)-xtmp(1))/2.0 + b(1) = (xtmp(1)+xtmp(2))/2.0 + DO i = 2, imtmp-1 + a(i) = b(i-1) + b(i) = (xtmp(i)+xtmp(i+1))/2.0 + ENDDO + a(imtmp) = b(imtmp-1) + b(imtmp) = xtmp(imtmp) + (xtmp(imtmp)-xtmp(imtmp-1))/2.0 + + c(1) = ytmp(1) - (ytmp(2)-ytmp(1))/2.0 + d(1) = (ytmp(1)+ytmp(2))/2.0 + DO j = 2, jmtmp-1 + c(j) = d(j-1) + d(j) = (ytmp(j)+ytmp(j+1))/2.0 + ENDDO + c(jmtmp) = d(jmtmp-1) + d(jmtmp) = ytmp(jmtmp) + (ytmp(jmtmp)-ytmp(jmtmp-1))/2.0 + + DO i = 1, imtmp + DO j = 1, jmtmp + number(i,j) = 0.0 + cham1tmp(i,j) = 0.0 + cham2tmp(i,j) = 0.0 + ENDDO + ENDDO +c +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, imtmp + DO jj = 1, jmtmp + DO i = 1, imrel + IF( ( xrel(i)-a(ii).GE.1.e-5.AND.xrel(i)-b(ii).LE.1.e-5 ).OR. + . ( xrel(i)-a(ii).LE.1.e-5.AND.xrel(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmrel + IF( (yrel(j)-c(jj).GE.1.e-5.AND.yrel(j)-d(jj).LE.1.e-5 ).OR. + . ( yrel(j)-c(jj).LE.1.e-5.AND.yrel(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + cham1tmp(ii,jj) = cham1tmp(ii,jj) + relief(i,j) + cham2tmp(ii,jj) = cham2tmp(ii,jj) + . + relief(i,j)*relief(i,j) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + DO i = 1, imtmp + DO j = 1, jmtmp + IF (number(i,j) .GT. 0.001) THEN + cham1tmp(i,j) = cham1tmp(i,j) / number(i,j) + cham2tmp(i,j) = cham2tmp(i,j) / number(i,j) + zzzz=cham2tmp(i,j)-cham1tmp(i,j)**2 + if (zzzz .lt. 0.0) then + if (zzzz .gt. -7.5) then + zzzz = 0.0 + print*,'Pb rugsoro, -7.5 < zzzz < 0, => zzz = 0.0' + else + stop 'Pb rugsoro, zzzz <-7.5' + endif + endif + cham2tmp(i,j) = SQRT(zzzz) + ELSE + PRINT*, 'probleme,i,j=', i,j + CALL ABORT + ENDIF + ENDDO + ENDDO +c + amin = cham2tmp(1,1) + AMAX = cham2tmp(1,1) + DO j = 1, jmtmp + DO i = 1, imtmp + IF (cham2tmp(i,j).GT.AMAX) AMAX = cham2tmp(i,j) + IF (cham2tmp(i,j).LT.amin) amin = cham2tmp(i,j) + ENDDO + ENDDO + PRINT*, 'Ecart-type 1x1:', amin, AMAX +c +c +c + a(1) = xmod(1) - (xmod(2)-xmod(1))/2.0 + b(1) = (xmod(1)+xmod(2))/2.0 + DO i = 2, immod-1 + a(i) = b(i-1) + b(i) = (xmod(i)+xmod(i+1))/2.0 + ENDDO + a(immod) = b(immod-1) + b(immod) = xmod(immod) + (xmod(immod)-xmod(immod-1))/2.0 + + c(1) = ymod(1) - (ymod(2)-ymod(1))/2.0 + d(1) = (ymod(1)+ymod(2))/2.0 + DO j = 2, jmmod-1 + c(j) = d(j-1) + d(j) = (ymod(j)+ymod(j+1))/2.0 + ENDDO + c(jmmod) = d(jmmod-1) + d(jmmod) = ymod(jmmod) + (ymod(jmmod)-ymod(jmmod-1))/2.0 +c + DO i = 1, immod + DO j = 1, jmmod + number(i,j) = 0.0 + rugs(i,j) = 0.0 + ENDDO + ENDDO +c +c +c +c ..... Modif P. Le Van ( 23/08/95 ) .... + + DO ii = 1, immod + DO jj = 1, jmmod + DO i = 1, imtmp + IF( ( xtmp(i)-a(ii).GE.1.e-5.AND.xtmp(i)-b(ii).LE.1.e-5 ).OR. + . ( xtmp(i)-a(ii).LE.1.e-5.AND.xtmp(i)-b(ii).GE.1.e-5 ) ) + . THEN + DO j = 1, jmtmp + IF( (ytmp(j)-c(jj).GE.1.e-5.AND.ytmp(j)-d(jj).LE.1.e-5 ).OR. + . ( ytmp(j)-c(jj).LE.1.e-5.AND.ytmp(j)-d(jj).GE.1.e-5 ) ) + . THEN + number(ii,jj) = number(ii,jj) + 1.0 + rugs(ii,jj) = rugs(ii,jj) + . + LOG(MAX(0.001_8,cham2tmp(i,j))) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c + DO i = 1, immod + DO j = 1, jmmod + IF (number(i,j) .GT. 0.001) THEN + rugs(i,j) = rugs(i,j) / number(i,j) + rugs(i,j) = EXP(rugs(i,j)) + ELSE + PRINT*, 'probleme,i,j=', i,j +ccc CALL ABORT + CALL dist_sphe(xmod(i),ymod(j),xtmp,ytmp,imtmp,jmtmp,distans) +#ifdef CRAY + ij_proche = ISMIN(imtmp*jmtmp,distans,1) +#else + ij_proche = 1 + zzmin = distans(ij_proche) + DO ii = 2, imtmp*jmtmp + IF (distans(ii).LT.zzmin) THEN + zzmin = distans(ii) + ij_proche = ii + ENDIF + ENDDO +#endif + j_proche = (ij_proche-1)/imtmp + 1 + i_proche = ij_proche - (j_proche-1)*imtmp + PRINT*, "solution:", ij_proche, i_proche, j_proche + rugs(i,j) = LOG(MAX(0.001_8,cham2tmp(i_proche,j_proche))) + ENDIF + ENDDO + ENDDO +c + amin = rugs(1,1) + AMAX = rugs(1,1) + DO j = 1, jmmod + DO i = 1, immod + IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j) + IF (rugs(i,j).LT.amin) amin = rugs(i,j) + ENDDO + ENDDO + PRINT*, 'Ecart-type du modele:', amin, AMAX +c + DO j = 1, jmmod + DO i = 1, immod + rugs(i,j) = rugs(i,j) / AMAX * 20.0 + ENDDO + ENDDO +c + amin = rugs(1,1) + AMAX = rugs(1,1) + DO j = 1, jmmod + DO i = 1, immod + IF (rugs(i,j).GT.AMAX) AMAX = rugs(i,j) + IF (rugs(i,j).LT.amin) amin = rugs(i,j) + ENDDO + ENDDO + PRINT*, 'Longueur de rugosite du modele:', amin, AMAX +c + RETURN + END +c + SUBROUTINE dist_sphe(rf_lon,rf_lat,rlon,rlat,im,jm,distance) +c +c Auteur: Laurent Li (le 30 decembre 1996) +c +c Ce programme calcule la distance minimale (selon le grand cercle) +c entre deux points sur la terre +c +c Input: + INTEGER im, jm ! dimensions + REAL rf_lon ! longitude du point de reference (degres) + REAL rf_lat ! latitude du point de reference (degres) + REAL rlon(im), rlat(jm) ! longitude et latitude des points +c +c Output: + REAL distance(im,jm) ! distances en metre +c + REAL rlon1, rlat1 + REAL rlon2, rlat2 + REAL dist + REAL pa, pb, p, pi +c + REAL radius + PARAMETER (radius=6371229.) +c + pi = 4.0 * ATAN(1.0) +c + DO 9999 j = 1, jm + DO 9999 i = 1, im +c + rlon1=rf_lon + rlat1=rf_lat + rlon2=rlon(i) + rlat2=rlat(j) + pa = pi/2.0 - rlat1*pi/180.0 ! dist. entre pole n et point a + pb = pi/2.0 - rlat2*pi/180.0 ! dist. entre pole n et point b + p = (rlon1-rlon2)*pi/180.0 ! angle entre a et b (leurs meridiens) +c + dist = ACOS( COS(pa)*COS(pb) + SIN(pa)*SIN(pb)*COS(p)) + dist = radius * dist + distance(i,j) = dist +c + 9999 CONTINUE +c + END Index: /LMDZ5/trunk/libf/dyn3dmem/grid_noro.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/grid_noro.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/grid_noro.F (revision 1632) @@ -0,0 +1,524 @@ +! +! $Id: grid_noro.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c +c + SUBROUTINE grid_noro(imdep, jmdep, xdata, ydata, zdata, + . imar, jmar, x, y, + . zphi,zmea,zstd,zsig,zgam,zthe, + . zpic,zval,mask) +c======================================================================= +c (F. Lott) (voir aussi z.x. Li, A. Harzallah et L. Fairhead) +c +c Compute the Parameters of the SSO scheme as described in +c LOTT & MILLER (1997) and LOTT(1999). +c Target points are on a rectangular grid: +c iim+1 latitudes including North and South Poles; +c jjm+1 longitudes, with periodicity jjm+1=1. +c aux poles. At the poles the fields value is repeated +c jjm+1 time. +c The parameters a,b,c,d represent the limite of the target +c gridpoint region. The means over this region are calculated +c from USN data, ponderated by a weight proportional to the +c surface occupated by the data inside the model gridpoint area. +c In most circumstances, this weight is the ratio between the +c surface of the USN gridpoint area and the surface of the +c model gridpoint area. +c +c (c) +c ----d----- +c | . . . .| +c | | +c (b)a . * . .b(a) +c | | +c | . . . .| +c ----c----- +c (d) +C======================================================================= +c INPUT: +c imdep, jmdep: dimensions X and Y input field +c xdata, ydata: coordinates X and Y input field +c zdata: Input field +c In this version it is assumed that the entry data come from +c the USNavy dataset: imdep=iusn=2160, jmdep=jusn=1080. +c OUTPUT: +c imar, jmar: dimensions X and Y Output field +c x, y: ccordinates X and Y Output field. +c zmea: Mean orographie +c zstd: Standard deviation +c zsig: Slope +c zgam: Anisotropy +c zthe: Orientation of the small axis +c zpic: Maximum altitude +c zval: Minimum altitude +C======================================================================= + + IMPLICIT INTEGER (I,J) + IMPLICIT REAL(X,Z) + + parameter(iusn=2160,jusn=1080,iext=216, epsfra = 1.e-5) +#include "dimensions.h" + REAL xusn(iusn+2*iext),yusn(jusn+2) + REAL zusn(iusn+2*iext,jusn+2) + + INTEGER imdep, jmdep + REAL xdata(imdep),ydata(jmdep) + REAL zdata(imdep,jmdep) +c + INTEGER imar, jmar + +C INTERMEDIATE FIELDS (CORRELATIONS OF OROGRAPHY GRADIENT) + + REAL ztz(iim+1,jjm+1),zxtzx(iim+1,jjm+1) + REAL zytzy(iim+1,jjm+1),zxtzy(iim+1,jjm+1) + REAL weight(iim+1,jjm+1) + +C CORRELATIONS OF USN OROGRAPHY GRADIENTS + + REAL zxtzxusn(iusn+2*iext,jusn+2),zytzyusn(iusn+2*iext,jusn+2) + REAL zxtzyusn(iusn+2*iext,jusn+2) + REAL x(imar+1),y(jmar),zphi(imar+1,jmar) + REAL zmea(imar+1,jmar),zstd(imar+1,jmar) + REAL zmea0(imar+1,jmar) ! GK211005 (CG) + REAL zsig(imar+1,jmar),zgam(imar+1,jmar),zthe(imar+1,jmar) + REAL zpic(imar+1,jmar),zval(imar+1,jmar) +cxxx PB integer mask(imar+1,jmar) + real mask(imar+1,jmar), mask_tmp(imar+1,jmar) + real num_tot(2200,1100),num_lan(2200,1100) +c + REAL a(2200),b(2200),c(1100),d(1100) + logical masque_lu +c + print *,' parametres de l orographie a l echelle sous maille' + xpi=acos(-1.) + rad = 6 371 229. + zdeltay=2.*xpi/REAL(jusn)*rad +c +c utilise-t'on un masque lu? +c + masque_lu = .true. + if (maxval(mask) == -99999 .and. minval(mask) == -99999) then + masque_lu= .false. + masque = 0.0 + endif + write(*,*)'Masque lu', masque_lu +c +c quelques tests de dimensions: +c +c + if(iim.ne.imar) STOP 'Problem dim. x' + if(jjm.ne.jmar-1) STOP 'Problem dim. y' + IF (imar.GT.2200 .OR. jmar.GT.1100) THEN + PRINT*, 'imar or jmar too big', imar, jmar + CALL ABORT + ENDIF + + IF(imdep.ne.iusn.or.jmdep.ne.jusn)then + print *,' imdep or jmdep bad dimensions:',imdep,jmdep + call abort + ENDIF + + IF(imar+1.ne.iim+1.or.jmar.ne.jjm+1)THEN + print *,' imar or jmar bad dimensions:',imar,jmar + call abort + ENDIF + + +c print *,'xdata:',xdata +c print *,'ydata:',ydata +c print *,'x:',x +c print *,'y:',y +c +C EXTENSION OF THE USN DATABASE TO POCEED COMPUTATIONS AT +C BOUNDARIES: +c + DO j=1,jusn + yusn(j+1)=ydata(j) + DO i=1,iusn + zusn(i+iext,j+1)=zdata(i,j) + xusn(i+iext)=xdata(i) + ENDDO + DO i=1,iext + zusn(i,j+1)=zdata(iusn-iext+i,j) + xusn(i)=xdata(iusn-iext+i)-2.*xpi + zusn(iusn+iext+i,j+1)=zdata(i,j) + xusn(iusn+iext+i)=xdata(i)+2.*xpi + ENDDO + ENDDO + + yusn(1)=ydata(1)+(ydata(1)-ydata(2)) + yusn(jusn+2)=ydata(jusn)+(ydata(jusn)-ydata(jusn-1)) + DO i=1,iusn/2+iext + zusn(i,1)=zusn(i+iusn/2,2) + zusn(i+iusn/2+iext,1)=zusn(i,2) + zusn(i,jusn+2)=zusn(i+iusn/2,jusn+1) + zusn(i+iusn/2+iext,jusn+2)=zusn(i,jusn+1) + ENDDO +c +c COMPUTE LIMITS OF MODEL GRIDPOINT AREA +C ( REGULAR GRID) +c + a(1) = x(1) - (x(2)-x(1))/2.0 + b(1) = (x(1)+x(2))/2.0 + DO i = 2, imar + a(i) = b(i-1) + b(i) = (x(i)+x(i+1))/2.0 + ENDDO + a(imar+1) = b(imar) + b(imar+1) = x(imar+1) + (x(imar+1)-x(imar))/2.0 + + c(1) = y(1) - (y(2)-y(1))/2.0 + d(1) = (y(1)+y(2))/2.0 + DO j = 2, jmar-1 + c(j) = d(j-1) + d(j) = (y(j)+y(j+1))/2.0 + ENDDO + c(jmar) = d(jmar-1) + d(jmar) = y(jmar) + (y(jmar)-y(jmar-1))/2.0 +c +c initialisations: +c + DO i = 1, imar+1 + DO j = 1, jmar + weight(i,j) = 0.0 + zxtzx(i,j) = 0.0 + zytzy(i,j) = 0.0 + zxtzy(i,j) = 0.0 + ztz(i,j) = 0.0 + zmea(i,j) = 0.0 + zpic(i,j) =-1.E+10 + zval(i,j) = 1.E+10 + ENDDO + ENDDO +c +c COMPUTE SLOPES CORRELATIONS ON USN GRID +c + DO j = 1,jusn+2 + DO i = 1, iusn+2*iext + zytzyusn(i,j)=0.0 + zxtzxusn(i,j)=0.0 + zxtzyusn(i,j)=0.0 + ENDDO + ENDDO + + + DO j = 2,jusn+1 + zdeltax=zdeltay*cos(yusn(j)) + DO i = 2, iusn+2*iext-1 + zytzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))**2/zdeltay**2 + zxtzxusn(i,j)=(zusn(i+1,j)-zusn(i-1,j))**2/zdeltax**2 + zxtzyusn(i,j)=(zusn(i,j+1)-zusn(i,j-1))/zdeltay + * *(zusn(i+1,j)-zusn(i-1,j))/zdeltax + ENDDO + ENDDO +c +c SUMMATION OVER GRIDPOINT AREA +c + zleny=xpi/REAL(jusn)*rad + xincr=xpi/2./REAL(jusn) + DO ii = 1, imar+1 + DO jj = 1, jmar + num_tot(ii,jj)=0. + num_lan(ii,jj)=0. +c PRINT *,' iteration ii jj:',ii,jj + DO j = 2,jusn+1 +c DO j = 3,jusn + zlenx=zleny*cos(yusn(j)) + zdeltax=zdeltay*cos(yusn(j)) + zbordnor=(c(jj)-yusn(j)+xincr)*rad + zbordsud=(yusn(j)-d(jj)+xincr)*rad + weighy=AMAX1(0., + * amin1(zbordnor,zbordsud,zleny)) + IF(weighy.ne.0)THEN + DO i = 2, iusn+2*iext-1 + zbordest=(xusn(i)-a(ii)+xincr)*rad*cos(yusn(j)) + zbordoue=(b(ii)+xincr-xusn(i))*rad*cos(yusn(j)) + weighx=AMAX1(0., + * amin1(zbordest,zbordoue,zlenx)) + IF(weighx.ne.0)THEN + num_tot(ii,jj)=num_tot(ii,jj)+1.0 + if(zusn(i,j).ge.1.)num_lan(ii,jj)=num_lan(ii,jj)+1.0 + weight(ii,jj)=weight(ii,jj)+weighx*weighy + zxtzx(ii,jj)=zxtzx(ii,jj)+zxtzxusn(i,j)*weighx*weighy + zytzy(ii,jj)=zytzy(ii,jj)+zytzyusn(i,j)*weighx*weighy + zxtzy(ii,jj)=zxtzy(ii,jj)+zxtzyusn(i,j)*weighx*weighy + ztz(ii,jj) =ztz(ii,jj) +zusn(i,j)*zusn(i,j)*weighx*weighy +c mean + zmea(ii,jj) =zmea(ii,jj)+zusn(i,j)*weighx*weighy +c peacks + zpic(ii,jj)=amax1(zpic(ii,jj),zusn(i,j)) +c valleys + zval(ii,jj)=amin1(zval(ii,jj),zusn(i,j)) + ENDIF + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +c +c COMPUTE PARAMETERS NEEDED BY THE LOTT & MILLER (1997) AND +C LOTT (1999) SSO SCHEME. +c + zllmmea=0. + zllmstd=0. + zllmsig=0. + zllmgam=0. + zllmpic=0. + zllmval=0. + zllmthe=0. + zminthe=0. +c print 100,' ' +c100 format(1X,A1,'II JJ',4X,'H',8X,'SD',8X,'SI',3X,'GA',3X,'TH') + DO ii = 1, imar+1 + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Mask +cXXX if(num_lan(ii,jj)/num_tot(ii,jj).ge.0.5)then +cXXX mask(ii,jj)=1 +cXXX else +cXXX mask(ii,jj)=0 +cXXX ENDIF + if (.not. masque_lu) then + mask(ii,jj) = num_lan(ii,jj)/num_tot(ii,jj) + endif +c Mean Orography: + zmea (ii,jj)=zmea (ii,jj)/weight(ii,jj) + zxtzx(ii,jj)=zxtzx(ii,jj)/weight(ii,jj) + zytzy(ii,jj)=zytzy(ii,jj)/weight(ii,jj) + zxtzy(ii,jj)=zxtzy(ii,jj)/weight(ii,jj) + ztz(ii,jj) =ztz(ii,jj)/weight(ii,jj) +c Standard deviation: + zstd(ii,jj)=sqrt(AMAX1(0.,ztz(ii,jj)-zmea(ii,jj)**2)) + ELSE + PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + ENDDO + ENDDO + +C CORRECT VALUES OF HORIZONTAL SLOPE NEAR THE POLES: + + DO ii = 1, imar+1 + zxtzx(ii,1)=zxtzx(ii,2) + zxtzx(ii,jmar)=zxtzx(ii,jmar-1) + zxtzy(ii,1)=zxtzy(ii,2) + zxtzy(ii,jmar)=zxtzy(ii,jmar-1) + zytzy(ii,1)=zytzy(ii,2) + zytzy(ii,jmar)=zytzy(ii,jmar-1) + ENDDO + +C FILTERS TO SMOOTH OUT FIELDS FOR INPUT INTO SSO SCHEME. + +C FIRST FILTER, MOVING AVERAGE OVER 9 POINTS. + + zmea0(:,:) = zmea(:,:) ! GK211005 (CG) on sauvegarde la topo non lissee + CALL MVA9(zmea,iim+1,jjm+1) + CALL MVA9(zstd,iim+1,jjm+1) + CALL MVA9(zpic,iim+1,jjm+1) + CALL MVA9(zval,iim+1,jjm+1) + CALL MVA9(zxtzx,iim+1,jjm+1) + CALL MVA9(zxtzy,iim+1,jjm+1) + CALL MVA9(zytzy,iim+1,jjm+1) +CXXX Masque prenant en compte maximum de terre +CXXX On seuil a 10% de terre de terre car en dessous les parametres de surface n'on +CXXX pas de sens (PB) + mask_tmp= 0.0 + WHERE(mask .GE. 0.1) mask_tmp = 1. + + DO ii = 1, imar + DO jj = 1, jmar + IF (weight(ii,jj) .NE. 0.0) THEN +c Coefficients K, L et M: + xk=(zxtzx(ii,jj)+zytzy(ii,jj))/2. + xl=(zxtzx(ii,jj)-zytzy(ii,jj))/2. + xm=zxtzy(ii,jj) + xp=xk-sqrt(xl**2+xm**2) + xq=xk+sqrt(xl**2+xm**2) + xw=1.e-8 + if(xp.le.xw) xp=0. + if(xq.le.xw) xq=xw + if(abs(xm).le.xw) xm=xw*sign(1.,xm) +c slope: +cXXX zsig(ii,jj)=sqrt(xq)*mask(ii,jj) +cXXXc isotropy: +cXXX zgam(ii,jj)=xp/xq*mask(ii,jj) +cXXXc angle theta: +cXXX zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask(ii,jj) +cXXX zphi(ii,jj)=zmea(ii,jj)*mask(ii,jj) +cXXX zmea(ii,jj)=zmea(ii,jj)*mask(ii,jj) +cXXX zpic(ii,jj)=zpic(ii,jj)*mask(ii,jj) +cXXX zval(ii,jj)=zval(ii,jj)*mask(ii,jj) +cXXX zstd(ii,jj)=zstd(ii,jj)*mask(ii,jj) +CXX* PB modif pour maque de terre fractionnaire +c slope: + zsig(ii,jj)=sqrt(xq)*mask_tmp(ii,jj) +c isotropy: + zgam(ii,jj)=xp/xq*mask_tmp(ii,jj) +c angle theta: + zthe(ii,jj)=57.29577951*atan2(xm,xl)/2.*mask_tmp(ii,jj) + ! GK211005 (CG) ne pas forcement lisser la topo + ! zphi(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj) + zphi(ii,jj)=zmea0(ii,jj)*mask_tmp(ii,jj) + ! + zmea(ii,jj)=zmea(ii,jj)*mask_tmp(ii,jj) + zpic(ii,jj)=zpic(ii,jj)*mask_tmp(ii,jj) + zval(ii,jj)=zval(ii,jj)*mask_tmp(ii,jj) + zstd(ii,jj)=zstd(ii,jj)*mask_tmp(ii,jj) +c print 101,ii,jj, +c * zmea(ii,jj),zstd(ii,jj),zsig(ii,jj),zgam(ii,jj), +c * zthe(ii,jj) +c101 format(1x,2(1x,i2),2(1x,f7.1),1x,f7.4,2x,f4.2,1x,f5.1) + ELSE +c PRINT*, 'probleme,ii,jj=', ii,jj + ENDIF + zllmmea=AMAX1(zmea(ii,jj),zllmmea) + zllmstd=AMAX1(zstd(ii,jj),zllmstd) + zllmsig=AMAX1(zsig(ii,jj),zllmsig) + zllmgam=AMAX1(zgam(ii,jj),zllmgam) + zllmthe=AMAX1(zthe(ii,jj),zllmthe) + zminthe=amin1(zthe(ii,jj),zminthe) + zllmpic=AMAX1(zpic(ii,jj),zllmpic) + zllmval=AMAX1(zval(ii,jj),zllmval) + ENDDO + ENDDO + print *,' MEAN ORO:',zllmmea + print *,' ST. DEV.:',zllmstd + print *,' PENTE:',zllmsig + print *,' ANISOTROP:',zllmgam + print *,' ANGLE:',zminthe,zllmthe + print *,' pic:',zllmpic + print *,' val:',zllmval + +C +c gamma and theta a 1. and 0. at poles +c + DO jj=1,jmar + zmea(imar+1,jj)=zmea(1,jj) + zphi(imar+1,jj)=zphi(1,jj) + zpic(imar+1,jj)=zpic(1,jj) + zval(imar+1,jj)=zval(1,jj) + zstd(imar+1,jj)=zstd(1,jj) + zsig(imar+1,jj)=zsig(1,jj) + zgam(imar+1,jj)=zgam(1,jj) + zthe(imar+1,jj)=zthe(1,jj) + ENDDO + + + zmeanor=0.0 + zmeasud=0.0 + zstdnor=0.0 + zstdsud=0.0 + zsignor=0.0 + zsigsud=0.0 + zweinor=0.0 + zweisud=0.0 + zpicnor=0.0 + zpicsud=0.0 + zvalnor=0.0 + zvalsud=0.0 + + DO ii=1,imar + zweinor=zweinor+ weight(ii, 1) + zweisud=zweisud+ weight(ii,jmar) + zmeanor=zmeanor+zmea(ii, 1)*weight(ii, 1) + zmeasud=zmeasud+zmea(ii,jmar)*weight(ii,jmar) + zstdnor=zstdnor+zstd(ii, 1)*weight(ii, 1) + zstdsud=zstdsud+zstd(ii,jmar)*weight(ii,jmar) + zsignor=zsignor+zsig(ii, 1)*weight(ii, 1) + zsigsud=zsigsud+zsig(ii,jmar)*weight(ii,jmar) + zpicnor=zpicnor+zpic(ii, 1)*weight(ii, 1) + zpicsud=zpicsud+zpic(ii,jmar)*weight(ii,jmar) + zvalnor=zvalnor+zval(ii, 1)*weight(ii, 1) + zvalsud=zvalsud+zval(ii,jmar)*weight(ii,jmar) + ENDDO + + DO ii=1,imar+1 + zmea(ii, 1)=zmeanor/zweinor + zmea(ii,jmar)=zmeasud/zweisud + zphi(ii, 1)=zmeanor/zweinor + zphi(ii,jmar)=zmeasud/zweisud + zpic(ii, 1)=zpicnor/zweinor + zpic(ii,jmar)=zpicsud/zweisud + zval(ii, 1)=zvalnor/zweinor + zval(ii,jmar)=zvalsud/zweisud + zstd(ii, 1)=zstdnor/zweinor + zstd(ii,jmar)=zstdsud/zweisud + zsig(ii, 1)=zsignor/zweinor + zsig(ii,jmar)=zsigsud/zweisud + zgam(ii, 1)=1. + zgam(ii,jmar)=1. + zthe(ii, 1)=0. + zthe(ii,jmar)=0. + ENDDO + + RETURN + END + + SUBROUTINE MVA9(X,IMAR,JMAR) + +C MAKE A MOVING AVERAGE OVER 9 GRIDPOINTS OF THE X FIELDS + + PARAMETER (ISMo=300,JSMo=200) + REAL X(IMAR,JMAR),XF(ISMo,JSMo) + real WEIGHTpb(-1:1,-1:1) + + if(imar.gt.ismo) stop'surdimensionner ismo dans mva9 (grid_noro)' + if(jmar.gt.jsmo) stop'surdimensionner jsmo dans mva9 (grid_noro)' + + SUM=0. + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=1./REAL((1+IS**2)*(1+JS**2)) + SUM=SUM+WEIGHTpb(IS,JS) + ENDDO + ENDDO + +c WRITE(*,*) 'MVA9 ', IMAR, JMAR +c WRITE(*,*) 'MVA9 ', WEIGHTpb +c WRITE(*,*) 'MVA9 SUM ', SUM + DO IS=-1,1 + DO JS=-1,1 + WEIGHTpb(IS,JS)=WEIGHTpb(IS,JS)/SUM + ENDDO + ENDDO + + DO J=2,JMAR-1 + DO I=2,IMAR-1 + XF(I,J)=0. + DO IS=-1,1 + DO JS=-1,1 + XF(I,J)=XF(I,J)+X(I+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + ENDDO + ENDDO + + DO J=2,JMAR-1 + XF(1,J)=0. + IS=IMAR-1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(IS,J+JS)*WEIGHTpb(-1,JS) + ENDDO + DO IS=0,1 + DO JS=-1,1 + XF(1,J)=XF(1,J)+X(1+IS,J+JS)*WEIGHTpb(IS,JS) + ENDDO + ENDDO + XF(IMAR,J)=XF(1,J) + ENDDO + + DO I=1,IMAR + XF(I,1)=XF(I,2) + XF(I,JMAR)=XF(I,JMAR-1) + ENDDO + + DO I=1,IMAR + DO J=1,JMAR + X(I,J)=XF(I,J) + ENDDO + ENDDO + + RETURN + END + + + Index: /LMDZ5/trunk/libf/dyn3dmem/grilles_gcm_netcdf.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/grilles_gcm_netcdf.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/grilles_gcm_netcdf.F (revision 1632) @@ -0,0 +1,305 @@ +! +! $Id: grilles_gcm_netcdf.F 1299 2010-01-20 14:27:21Z fairhead $ +! +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/dyn3dmem/groupe_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/groupe_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/groupe_loc.F (revision 1632) @@ -0,0 +1,135 @@ + subroutine groupe_loc(pext,pbaru,pbarv,pbarum,pbarvm,wm) + USE parallel + USE Write_field_loc + USE groupe_mod + implicit none + +c sous-programme servant a fitlrer les champs de flux de masse aux +c poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur +c et a mesure qu'on se rapproche du pole. +c +c en entree: pext, pbaru et pbarv +c +c en sortie: pbarum,pbarvm et wm. +c +c remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc +c pas besoin de w en entree. + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" +#include "comvert.h" + + integer ngroup + parameter (ngroup=3) + + + real pbaru(iip1,jjb_u:jje_u,llm),pbarv(iip1,jjb_v:jje_v,llm) + real pext(iip1,jjb_u:jje_u,llm) + + real pbarum(iip1,jjb_u:jje_u,llm),pbarvm(iip1,jjb_v:jje_v,llm) + real wm(iip1,jjb_u:jje_u,llm) + + + real uu + + integer i,j,l + + logical firstcall + save firstcall +c$OMP THREADPRIVATE(firstcall) + + data firstcall/.true./ + integer ijb,ije,jjb,jje + + if (firstcall) then + if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre ede point' + firstcall=.false. + endif + +c Champs 1D + + call convflu_loc(pbaru,pbarv,llm,zconvm) + +c +c call scopy(ijp1llm,zconvm,1,zconvmm,1) +c call scopy(ijmllm,pbarv,1,pbarvm,1) + + jjb=jj_begin + jje=jj_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + zconvmm(:,jjb:jje,l)=zconvm(:,jjb:jje,l) + enddo +c$OMP END DO NOWAIT + + call groupeun_loc(jjp1,llm,jjb_u,jje_u,jjb,jje,zconvmm) + + jjb=jj_begin-1 + jje=jj_end + if (pole_nord) jjb=jj_begin + if (pole_sud) jje=jj_end-1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + pbarvm(:,jjb:jje,l)=pbarv(:,jjb:jje,l) + enddo +c$OMP END DO NOWAIT + +#ifdef DEBUG_IO + CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/))) +#endif + call groupeun_loc(jjm,llm,jjb_v,jje_v,jjb,jje,pbarvm) +#ifdef DEBUG_IO + CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/))) +#endif +c Champs 3D + + jjb=jj_begin + jje=jj_end + if (pole_nord) jjb=jj_begin+1 + if (pole_sud) jje=jj_end-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + uu=pbaru(iim,j,l) + do i=1,iim + uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l) + pbarum(i,j,l)=uu +c zconvm(i,j,l ) = xflu(i-1,j,l)-xflu(i,j,l)+ +c * yflu(i,j,l)-yflu(i,j-1,l) + enddo + pbarum(iip1,j,l)=pbarum(1,j,l) + enddo + enddo +c$OMP END DO NOWAIT +c integration de la convergence de masse de haut en bas ...... + + jjb=jj_begin + jje=jj_end + +c$OMP BARRIER +c$OMP MASTER + do l = llm-1,1,-1 + do j=jjb,jje + do i=1,iip1 + zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1) + enddo + enddo + enddo + + if (.not. pole_sud) then + zconvmm(:,jj_end+1,:)=0 +cym wm(:,jj_end+1,:)=0 + endif + +c$OMP END MASTER +c$OMP BARRIER + + CALL vitvert_loc(zconvmm,wm) + + return + end + Index: /LMDZ5/trunk/libf/dyn3dmem/groupe_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/groupe_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/groupe_mod.F90 (revision 1632) @@ -0,0 +1,40 @@ +MODULE groupe_mod + + REAL,POINTER,SAVE :: zconvm(:,:,:) + REAL,POINTER,SAVE :: zconvmm(:,:,:) + +CONTAINS + + SUBROUTINE groupe_allocate + USE bands + USE allocate_field + USE parallel + USE infotrac + USE advtrac_mod, ONLY : advtrac_allocate + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + TYPE(distrib),POINTER :: d + + d=>distrib_caldyn + CALL allocate2d_u(zconvm,llm,d) + CALL allocate2d_u(zconvmm,llm,d) + + + END SUBROUTINE groupe_allocate + + SUBROUTINE groupe_switch_caldyn(dist) + USE allocate_field + USE bands + USE parallel + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch2d_u(zconvm,distrib_caldyn,dist) + CALL switch2d_u(zconvmm,distrib_caldyn,dist) + + END SUBROUTINE groupe_switch_caldyn + + + +END MODULE groupe_mod Index: /LMDZ5/trunk/libf/dyn3dmem/groupeun_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/groupeun_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/groupeun_loc.F (revision 1632) @@ -0,0 +1,201 @@ + SUBROUTINE groupeun_loc(jjmax,llmax,sb,se,jjb,jje,q) + USE parallel + USE Write_Field_p + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + INTEGER jjmax,llmax,sb,se,jjb,jje + REAL q(iip1,sb:se,llmax) + + INTEGER ngroup + PARAMETER (ngroup=3) + + REAL airecn,qn + REAL airecs,qs + + INTEGER i,j,l,ig,ig2,j1,j2,i0,jd + +c--------------------------------------------------------------------c +c Strategie d'optimisation c +c stocker les valeurs systematiquement recalculees c +c et identiques d'un pas de temps sur l'autre. Il s'agit des c +c aires des cellules qui sont sommees. S'il n'y a pas de changement c +c de grille au cours de la simulation tout devrait bien se passer. c +c Autre optimisation : determination des bornes entre lesquelles "j" c +c varie, au lieu de faire un test a chaque fois... +c--------------------------------------------------------------------c + + INTEGER j_start, j_finish + + REAL, SAVE :: airen_tab(iip1,jjp1,0:1) + REAL, SAVE :: aires_tab(iip1,jjp1,0:1) +!$OMP THREADPRIVATE(airen_tab, aires_tab) + + LOGICAL, SAVE :: first = .TRUE. +!$OMP THREADPRIVATE(first) + INTEGER,SAVE :: i_index(iim,ngroup) + INTEGER :: offset + REAL :: qsum(iim/ngroup) + + IF (first) THEN + CALL init_groupeun_loc(airen_tab, aires_tab) + first = .FALSE. + ENDIF + +c Champs 3D + jd=jjp1-jjmax +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + j1=1+jd + j2=2 + DO ig=1,ngroup + +c Concerne le pole nord + j_start = MAX(jjb, j1-jd) + j_finish = MIN(jje, j2-jd) + DO ig2=1,ngroup-ig+1 + offset=2**(ig2-1) + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i0=1,iim,2**ig2 + q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l) + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i=1,iim + q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l) + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR ON_ADB(airen_tab) +!CDIR ON_ADB(q) + DO i=1,iim + q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd) + ENDDO + q(iip1,j,l)=q(1,j,l) + ENDDO + +!c Concerne le pole sud + j_start = MAX(1+jjp1-jje-jd, j1-jd) + j_finish = MIN(1+jjp1-jjb-jd, j2-jd) + DO ig2=1,ngroup-ig+1 + offset=2**(ig2-1) + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i0=1,iim,2**ig2 + q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l) + & +q(i0+offset,jjp1-j+1-jd,l) + ENDDO + ENDDO + ENDDO + + + DO j=j_start, j_finish +!CDIR NODEP +!CDIR ON_ADB(q) + DO i=1,iim + q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)), + & jjp1-j+1-jd,l) + ENDDO + ENDDO + + DO j=j_start, j_finish +!CDIR ON_ADB(aires_tab) +!CDIR ON_ADB(q) + DO i=1,iim + q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)* + & aires_tab(i,jjp1-j+1,jd) + ENDDO + q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l) + ENDDO + + + j1=j2+1 + j2=j2+2**ig + ENDDO + ENDDO +!$OMP END DO NOWAIT + + RETURN + END + + + + SUBROUTINE init_groupeun_loc(airen_tab, aires_tab) + + USE parallel + IMPLICIT NONE + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom2.h" + + INTEGER ngroup + PARAMETER (ngroup=3) + + REAL airen,airecn + REAL aires,airecs + + INTEGER i,j,l,ig,j1,j2,i0,jd + + INTEGER j_start, j_finish + + REAL :: airen_tab(iip1,jjp1,0:1) + REAL :: aires_tab(iip1,jjp1,0:1) + + DO jd=0, 1 + j1=1+jd + j2=2 + DO ig=1,ngroup + +! c Concerne le pole nord + j_start = j1-jd + j_finish = j2-jd + DO j=j_start, j_finish + DO i0=1,iim,2**(ngroup-ig+1) + airen=0. + DO i=i0,i0+2**(ngroup-ig+1)-1 + airen = airen+aire(i,j) + ENDDO + DO i=i0,i0+2**(ngroup-ig+1)-1 + airen_tab(i,j,jd) = + & aire(i,j) / airen + ENDDO + ENDDO + ENDDO + +! c Concerne le pole sud + j_start = j1-jd + j_finish = j2-jd + DO j=j_start, j_finish + DO i0=1,iim,2**(ngroup-ig+1) + aires=0. + DO i=i0,i0+2**(ngroup-ig+1)-1 + aires=aires+aire(i,jjp1-j+1) + ENDDO + DO i=i0,i0+2**(ngroup-ig+1)-1 + aires_tab(i,jjp1-j+1,jd) = + & aire(i,jjp1-j+1) / aires + ENDDO + ENDDO + ENDDO + + j1=j2+1 + j2=j2+2**ig + ENDDO + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/guide_loc_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/guide_loc_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/guide_loc_mod.F90 (revision 1632) @@ -0,0 +1,1967 @@ +! +! $Id$ +! +MODULE guide_loc_mod + +!======================================================================= +! Auteur: F.Hourdin +! F. Codron 01/09 +!======================================================================= + + USE getparam + USE Write_Field_loc + use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close + USE parallel + + IMPLICIT NONE + +! --------------------------------------------- +! Declarations des cles logiques et parametres +! --------------------------------------------- + INTEGER, PRIVATE, SAVE :: iguide_read,iguide_int,iguide_sav + INTEGER, PRIVATE, SAVE :: nlevnc, guide_plevs + LOGICAL, PRIVATE, SAVE :: guide_u,guide_v,guide_T,guide_Q,guide_P + LOGICAL, PRIVATE, SAVE :: guide_hr,guide_teta + LOGICAL, PRIVATE, SAVE :: guide_BL,guide_reg,guide_add,gamma4,guide_zon + LOGICAL, PRIVATE, SAVE :: invert_p,invert_y,ini_anal + LOGICAL, PRIVATE, SAVE :: guide_2D,guide_sav,guide_modele + + REAL, PRIVATE, SAVE :: tau_min_u,tau_max_u + REAL, PRIVATE, SAVE :: tau_min_v,tau_max_v + REAL, PRIVATE, SAVE :: tau_min_T,tau_max_T + REAL, PRIVATE, SAVE :: tau_min_Q,tau_max_Q + REAL, PRIVATE, SAVE :: tau_min_P,tau_max_P + + REAL, PRIVATE, SAVE :: lat_min_g,lat_max_g + REAL, PRIVATE, SAVE :: lon_min_g,lon_max_g + REAL, PRIVATE, SAVE :: tau_lon,tau_lat + + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_u,alpha_v + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_T,alpha_Q + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_P,alpha_pcor + +! --------------------------------------------- +! Variables de guidage +! --------------------------------------------- +! Variables des fichiers de guidage + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: unat1,unat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: vnat1,vnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: tnat1,tnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: qnat1,qnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: pnat1,pnat2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: psnat1,psnat2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: apnc,bpnc +! Variables aux dimensions du modele + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: ugui1,ugui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: vgui1,vgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: tgui1,tgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: qgui1,qgui2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: psgui1,psgui2 + + INTEGER,SAVE,PRIVATE :: ijbu,ijbv,ijeu,ijev,ijnu,ijnv + INTEGER,SAVE,PRIVATE :: jjbu,jjbv,jjeu,jjev,jjnu,jjnv + + +CONTAINS +!======================================================================= + + SUBROUTINE guide_init + + USE control_mod + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + + INTEGER :: error,ncidpl,rid,rcod + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'guide_init' + +! --------------------------------------------- +! Lecture des parametres: +! --------------------------------------------- +! Variables guidees + CALL getpar('guide_u',.true.,guide_u,'guidage de u') + CALL getpar('guide_v',.true.,guide_v,'guidage de v') + CALL getpar('guide_T',.true.,guide_T,'guidage de T') + CALL getpar('guide_P',.true.,guide_P,'guidage de P') + CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q') + CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R') + CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta') + + CALL getpar('guide_add',.false.,guide_add,'for�age constant?') + CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale') + +! Constantes de rappel. Unite : fraction de jour + CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u') + CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u') + CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v') + CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v') + CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T') + CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T') + CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q') + CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q') + CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P') + CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P') + CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie') + CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim') + +! Sauvegarde du for�age + CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage') + CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage') + ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois. + IF (iguide_sav.GT.0) THEN + iguide_sav=day_step/iguide_sav + ELSE + iguide_sav=day_step*iguide_sav + ENDIF + +! Guidage regional seulement (sinon constant ou suivant le zoom) + CALL getpar('guide_reg',.false.,guide_reg,'guidage regional') + CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ') + CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ') + CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ') + CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ') + CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ') + CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ') + +! Parametres pour lecture des fichiers + CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage') + CALL getpar('iguide_int',4,iguide_int,'freq. interpolation vert') + IF (iguide_int.EQ.0) THEN + iguide_int=1 + ELSEIF (iguide_int.GT.0) THEN + iguide_int=day_step/iguide_int + ELSE + iguide_int=day_step*iguide_int + ENDIF + CALL getpar('guide_plevs',0,guide_plevs,'niveaux pression fichiers guidage') + ! Pour compatibilite avec ancienne version avec guide_modele + CALL getpar('guide_modele',.false.,guide_modele,'niveaux pression ap+bp*psol') + IF (guide_modele) THEN + guide_plevs=1 + ENDIF + ! Fin raccord + CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse') + CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses') + CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S') + CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P') + +! --------------------------------------------- +! Determination du nombre de niveaux verticaux +! des fichiers guidage +! --------------------------------------------- + ncidpl=-99 + if (guide_plevs.EQ.1) then + if (ncidpl.eq.-99) rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl) + elseif (guide_plevs.EQ.2) then + if (ncidpl.EQ.-99) rcod=nf90_open('P.nc',Nf90_NOWRITe,ncidpl) + elseif (guide_u) then + if (ncidpl.eq.-99) rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl) + elseif (guide_v) then + if (ncidpl.eq.-99) rcod=nf90_open('v.nc',nf90_nowrite,ncidpl) + elseif (guide_T) then + if (ncidpl.eq.-99) rcod=nf90_open('T.nc',nf90_nowrite,ncidpl) + elseif (guide_Q) then + if (ncidpl.eq.-99) rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl) + endif + error=NF_INQ_DIMID(ncidpl,'LEVEL',rid) + IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid) + IF (error.NE.NF_NOERR) THEN + print *,'Guide: probleme lecture niveaux pression' + CALL abort_gcm(modname,abort_message,1) + ENDIF + error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc) + print *,'Guide: nombre niveaux vert. nlevnc', nlevnc + rcod = nf90_close(ncidpl) + +! --------------------------------------------- +! Allocation des variables +! --------------------------------------------- + abort_message='pb in allocation guide' + + ALLOCATE(apnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(bpnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + apnc=0.;bpnc=0. + + ALLOCATE(alpha_pcor(llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_u(ijb_u:ije_u), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_v(ijb_v:ije_v), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_T(ijb_u:ije_u), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_Q(ijb_u:ije_u), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_P(ijb_u:ije_u), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0 + + IF (guide_u) THEN + ALLOCATE(unat1(iip1,jjb_u:jje_u,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui1(ijb_u:ije_u,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(unat2(iip1,jjb_u:jje_u,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui2(ijb_u:ije_u,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + unat1=0.;unat2=0.;ugui1=0.;ugui2=0. + ENDIF + + IF (guide_T) THEN + ALLOCATE(tnat1(iip1,jjb_u:jje_u,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui1(ijb_u:ije_u,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tnat2(iip1,jjb_u:jje_u,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui2(ijb_u:ije_u,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0. + ENDIF + + IF (guide_Q) THEN + ALLOCATE(qnat1(iip1,jjb_u:jje_u,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui1(ijb_u:ije_u,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qnat2(iip1,jjb_u:jje_u,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui2(ijb_u:ije_u,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0. + ENDIF + + IF (guide_v) THEN + ALLOCATE(vnat1(iip1,jjb_v:jje_v,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui1(ijb_v:ije_v,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vnat2(iip1,jjb_v:jje_v,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui2(ijb_v:ije_v,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0. + ENDIF + + IF (guide_plevs.EQ.2) THEN + ALLOCATE(pnat1(iip1,jjb_u:jje_u,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(pnat2(iip1,jjb_u:jje_u,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + pnat1=0.;pnat2=0.; + ENDIF + + IF (guide_P.OR.guide_plevs.EQ.1) THEN + ALLOCATE(psnat1(iip1,jjb_u:jje_u), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psnat2(iip1,jjb_u:jje_u), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psnat1=0.;psnat2=0.; + ENDIF + IF (guide_P) THEN + ALLOCATE(psgui2(ijb_u:ije_u), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psgui1(ijb_u:ije_u), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psgui1=0.;psgui2=0. + ENDIF + +! --------------------------------------------- +! Lecture du premier etat de guidage. +! --------------------------------------------- + IF (guide_2D) THEN + CALL guide_read2D(1) + ELSE + CALL guide_read(1) + ENDIF + IF (guide_v) vnat1=vnat2 + IF (guide_u) unat1=unat2 + IF (guide_T) tnat1=tnat2 + IF (guide_Q) qnat1=qnat2 + IF (guide_plevs.EQ.2) pnat1=pnat2 + IF (guide_P.OR.guide_plevs.EQ.1) psnat1=psnat2 + + END SUBROUTINE guide_init + +!======================================================================= + SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps) + use parallel + USE control_mod + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + INTEGER, INTENT(IN) :: itau !pas de temps + REAL, DIMENSION (ijb_u:ije_u,llm), INTENT(INOUT) :: ucov,teta,q,masse + REAL, DIMENSION (ijb_v:ije_v,llm), INTENT(INOUT) :: vcov + REAL, DIMENSION (ijb_u:ije_u), INTENT(INOUT) :: ps + + ! Variables locales + LOGICAL, SAVE :: first=.TRUE. +!$OMP THREADPRIVATE(first) + LOGICAL :: f_out ! sortie guidage + REAL, DIMENSION (ijb_u:ije_u,llm) :: f_add ! var aux: champ de guidage + ! Variables pour fonction Exner (P milieu couche) + REAL, DIMENSION (iip1,jjb_u:jje_u,llm) :: pk, pkf + REAL, DIMENSION (iip1,jjb_u:jje_u,llm) :: alpha, beta + REAL, DIMENSION (iip1,jjb_u:jje_u) :: pks + REAL :: unskap + REAL, DIMENSION (ijb_u:ije_u,llmp1) :: p ! besoin si guide_P + ! Compteurs temps: + INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage +!$OMP THREADPRIVATE(step_rea,count_no_rea,itau_test) + REAL :: ditau, dday_step + REAL :: tau,reste ! position entre 2 etats de guidage + REAL, SAVE :: factt ! pas de temps en fraction de jour +!$OMP THREADPRIVATE(factt) + + INTEGER :: i,j,l + +!$OMP MASTER + ijbu=ij_begin ; ijeu=ij_end ; ijnu=ijeu-ijbu+1 + jjbu=jj_begin ; jjeu=jj_end ; jjnu=jjeu-jjbu+1 + ijbv=ij_begin ; ijev=ij_end ; ijnv=ijev-ijbv+1 + jjbv=jj_begin ; jjev=jj_end ; jjnv=jjev-jjbv+1 + IF (pole_sud) THEN + ijev=ij_end-iip1 + jjev=jj_end-1 + ijnv=ijev-ijbv+1 + jjnv=jjev-jjbv+1 + ENDIF +!$OMP END MASTER +!$OMP BARRIER + + PRINT *,'---> on rentre dans guide_main' +! CALL AllGather_Field(ucov,ip1jmp1,llm) +! CALL AllGather_Field(vcov,ip1jm,llm) +! CALL AllGather_Field(teta,ip1jmp1,llm) +! CALL AllGather_Field(ps,ip1jmp1,1) +! CALL AllGather_Field(q,ip1jmp1,llm) + +!----------------------------------------------------------------------- +! Initialisations au premier passage +!----------------------------------------------------------------------- + + IF (first) THEN + first=.FALSE. +!$OMP MASTER + CALL guide_init +!$OMP END MASTER +!$OMP BARRIER + itau_test=1001 + step_rea=1 + count_no_rea=0 +! Calcul des constantes de rappel + factt=dtvr*iperiod/daysec +!$OMP MASTER + call tau2alpha(3,iip1,jjnb_v ,factt,tau_min_v,tau_max_v,alpha_v) + call tau2alpha(2,iip1,jjnb_u,factt,tau_min_u,tau_max_u,alpha_u) + call tau2alpha(1,iip1,jjnb_u,factt,tau_min_T,tau_max_T,alpha_T) + call tau2alpha(1,iip1,jjnb_u,factt,tau_min_P,tau_max_P,alpha_P) + call tau2alpha(1,iip1,jjnb_u,factt,tau_min_Q,tau_max_Q,alpha_Q) +! correction de rappel dans couche limite + if (guide_BL) then + alpha_pcor(:)=1. + else + do l=1,llm + alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2. + enddo + endif +!$OMP END MASTER +! ini_anal: etat initial egal au guidage + IF (ini_anal) THEN + CALL guide_interp(ps,teta) + IF (guide_u) ucov(ijbu:ijeu,:)=ugui2(ijbu:ijeu,:) + IF (guide_v) vcov(ijbv:ijev,:)=ugui2(ijbv:ijev,:) + IF (guide_T) teta(ijbu:ijeu,:)=tgui2(ijbu:ijeu,:) + IF (guide_Q) q(ijbu:ijeu,:)=qgui2(ijbu:ijeu,:) + IF (guide_P) THEN + ps(ijbu:ijeu)=psgui2(ijbu:ijeu) + CALL pression_loc(ijnb_u,ap,bp,ps,p) + CALL massdair_loc(p,masse) + ENDIF + RETURN + ENDIF +! Verification structure guidage + IF (guide_u) THEN +!+tard CALL writefield_u('unat',unat1) + CALL writefield_u('ucov',ucov) + ENDIF + IF (guide_T) THEN +!+tard CALL writefield_p('tnat',tnat1) + CALL writefield_u('teta',teta) + ENDIF + + ENDIF !first + +!----------------------------------------------------------------------- +! Lecture des fichiers de guidage ? +!----------------------------------------------------------------------- + IF (iguide_read.NE.0) THEN + ditau=real(itau) + dday_step=real(day_step) + IF (iguide_read.LT.0) THEN + tau=ditau/dday_step/REAL(iguide_read) + ELSE + tau=REAL(iguide_read)*ditau/dday_step + ENDIF + reste=tau-AINT(tau) + IF (reste.EQ.0.) THEN + IF (itau_test.EQ.itau) THEN + write(*,*)'deuxieme passage de advreel a itau=',itau + stop + ELSE + IF (guide_v) vnat1(:,jjbv:jjev,:)=vnat2(:,jjbv:jjev,:) + IF (guide_u) unat1(:,jjbu:jjeu,:)=unat2(:,jjbu:jjeu,:) + IF (guide_T) tnat1(:,jjbu:jjeu,:)=tnat2(:,jjbu:jjeu,:) + IF (guide_Q) qnat1(:,jjbu:jjeu,:)=qnat2(:,jjbu:jjeu,:) + IF (guide_plevs.EQ.2) pnat1(:,jjbu:jjeu,:)=pnat2(:,jjbu:jjeu,:) + IF (guide_P.OR.guide_plevs.EQ.1) psnat1(:,jjbu:jjeu)=psnat2(:,jjbu:jjeu) + step_rea=step_rea+1 + itau_test=itau + print*,'Lecture fichiers guidage, pas ',step_rea, & + 'apres ',count_no_rea,' non lectures' + IF (guide_2D) THEN + CALL guide_read2D(step_rea) + ELSE + CALL guide_read(step_rea) + ENDIF + count_no_rea=0 + ENDIF + ELSE + count_no_rea=count_no_rea+1 + + ENDIF + ENDIF !iguide_read=0 + +!----------------------------------------------------------------------- +! Interpolation et conversion des champs de guidage +!----------------------------------------------------------------------- + IF (MOD(itau,iguide_int).EQ.0) THEN + CALL guide_interp(ps,teta) + ENDIF +! Repartition entre 2 etats de guidage + IF (iguide_read.NE.0) THEN + tau=reste + ELSE + tau=1. + ENDIF + +!----------------------------------------------------------------------- +! Ajout des champs de guidage +!----------------------------------------------------------------------- +! Sauvegarde du guidage? + f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav) + IF (f_out) THEN +! Calcul niveaux pression milieu de couches + CALL pression_loc( ijnb_u, ap, bp, ps, p ) + if (disvert_type==1) then + CALL exner_hyb_loc(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf) + else + CALL exner_milieu_loc(ip1jmp1,ps,p,beta,pks,pk,pkf) + endif + unskap=1./kappa + DO l = 1, llm + DO j=jjbu,jjeu + DO i =1, iip1 + p(i+(j-1)*iip1,l) = preff * ( pk(i,j,l)/cpp) ** unskap + ENDDO + ENDDO + ENDDO + CALL guide_out("P",jjp1,llm,p,1.) + ENDIF + + if (guide_u) then + if (guide_add) then + f_add(ijbu:ijeu,:)=(1.-tau)*ugui1(ijbu:ijeu,:)+tau*ugui2(ijbu:ijeu,:) + else + f_add(ijbu:ijeu,:)=(1.-tau)*ugui1(ijbu:ijeu,:)+tau*ugui2(ijbu:ijeu,:)-ucov(ijbu:ijeu,:) + endif + + if (guide_zon) CALL guide_zonave_u(1,llm,f_add) + CALL guide_addfield_u(llm,f_add,alpha_u) + IF (f_out) CALL guide_out("U",jjp1,llm,f_add(:,:),factt) + ucov(ijbu:ijeu,:)=ucov(ijbu:ijeu,:)+f_add(ijbu:ijeu,:) + endif + + if (guide_T) then + if (guide_add) then + f_add(ijbu:ijeu,:)=(1.-tau)*tgui1(ijbu:ijeu,:)+tau*tgui2(ijbu:ijeu,:) + else + f_add(ijbu:ijeu,:)=(1.-tau)*tgui1(ijbu:ijeu,:)+tau*tgui2(ijbu:ijeu,:)-teta(ijbu:ijeu,:) + endif + if (guide_zon) CALL guide_zonave_u(2,llm,f_add) + CALL guide_addfield_u(llm,f_add,alpha_T) + IF (f_out) CALL guide_out("T",jjp1,llm,f_add(:,:),factt) + teta(ijbu:ijeu,:)=teta(ijbu:ijeu,:)+f_add(ijbu:ijeu,:) + endif + + if (guide_P) then + if (guide_add) then + f_add(ijbu:ijeu,1)=(1.-tau)*psgui1(ijbu:ijeu)+tau*psgui2(ijbu:ijeu) + else + f_add(ijbu:ijeu,1)=(1.-tau)*psgui1(ijbu:ijeu)+tau*psgui2(ijbu:ijeu)-ps(ijbu:ijeu) + endif + if (guide_zon) CALL guide_zonave_u(2,1,f_add(ijb_u:ije_u,1)) + CALL guide_addfield_u(1,f_add(ijb_u:ije_u,1),alpha_P) + IF (f_out) CALL guide_out("SP",jjp1,1,f_add(1:ip1jmp1,1),factt) + ps(ijbu:ijeu)=ps(ijbu:ijeu)+f_add(ijbu:ijeu,1) + CALL pression_loc(ijnb_u,ap,bp,ps,p) + CALL massdair_loc(p,masse) + endif + + if (guide_Q) then + if (guide_add) then + f_add(ijbu:ijeu,:)=(1.-tau)*qgui1(ijbu:ijeu,:)+tau*qgui2(ijbu:ijeu,:) + else + f_add(ijbu:ijeu,:)=(1.-tau)*qgui1(ijbu:ijeu,:)+tau*qgui2(ijbu:ijeu,:)-q(ijbu:ijeu,:) + endif + if (guide_zon) CALL guide_zonave_u(2,llm,f_add) + CALL guide_addfield_u(llm,f_add,alpha_Q) + IF (f_out) CALL guide_out("Q",jjp1,llm,f_add(:,:),factt) + q(ijbu:ijeu,:)=q(ijbu:ijeu,:)+f_add(ijbu:ijeu,:) + endif + + if (guide_v) then + if (guide_add) then + f_add(ijbv:ijev,:)=(1.-tau)*vgui1(ijbv:ijev,:)+tau*vgui2(ijbv:ijev,:) + else + f_add(ijbv:ijev,:)=(1.-tau)*vgui1(ijbv:ijev,:)+tau*vgui2(ijbv:ijev,:)-vcov(ijbv:ijev,:) + endif + + if (guide_zon) CALL guide_zonave_v(2,jjm,llm,f_add(ijb_v:ije_v,:)) + CALL guide_addfield_v(llm,f_add(ijb_v:ije_v,:),alpha_v) + IF (f_out) CALL guide_out("V",jjm,llm,f_add(1:ip1jm,:),factt) + vcov(ijbv:ijev,:)=vcov(ijbv:ijev,:)+f_add(ijbv:ijev,:) + endif + + END SUBROUTINE guide_main + + + SUBROUTINE guide_addfield_u(vsize,field,alpha) +! field1=a*field1+alpha*field2 + + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + + ! input variables + INTEGER, INTENT(IN) :: vsize + REAL, DIMENSION(ijb_u:ije_u), INTENT(IN) :: alpha + REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field + + ! Local variables + INTEGER :: l + + DO l=1,vsize + field(ijbu:ijeu,l)=alpha(ijbu:ijeu)*field(ijbu:ijeu,l)*alpha_pcor(l) + ENDDO + + END SUBROUTINE guide_addfield_u + + + SUBROUTINE guide_addfield_v(vsize,field,alpha) +! field1=a*field1+alpha*field2 + + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + + ! input variables + INTEGER, INTENT(IN) :: vsize + REAL, DIMENSION(ijb_v:ije_v), INTENT(IN) :: alpha + REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field + + ! Local variables + INTEGER :: l + + DO l=1,vsize + field(ijbv:ijev,l)=alpha(ijbv:ijev)*field(ijbv:ijev,l)*alpha_pcor(l) + ENDDO + + END SUBROUTINE guide_addfield_v + +!======================================================================= + + SUBROUTINE guide_zonave_u(typ,vsize,field) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comgeom.h" + INCLUDE "comconst.h" + + ! input/output variables + INTEGER, INTENT(IN) :: typ + INTEGER, INTENT(IN) :: vsize + REAL, DIMENSION(ijb_u:ije_u,vsize), INTENT(INOUT) :: field + + ! Local variables + LOGICAL, SAVE :: first=.TRUE. + INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain + INTEGER :: i,j,l,ij + REAL, DIMENSION (iip1) :: lond ! longitude in Deg. + REAL, DIMENSION (jjb_u:jje_u,vsize):: fieldm ! zon-averaged field + + IF (first) THEN + first=.FALSE. +!Compute domain for averaging + lond=rlonu*180./pi + imin(1)=1;imax(1)=iip1; + imin(2)=1;imax(2)=iip1; + IF (guide_reg) THEN + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(1)=i + IF (lond(i).LE.lon_max_g) imax(1)=i + ENDDO + lond=rlonv*180./pi + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(2)=i + IF (lond(i).LE.lon_max_g) imax(2)=i + ENDDO + ENDIF + ENDIF + + fieldm=0. + + DO l=1,vsize + ! Compute zonal average + +!correction bug ici +! ---> a verifier +! ym DO j=jjbv,jjev + DO j=jjbu,jjeu + DO i=imin(typ),imax(typ) + ij=(j-1)*iip1+i + fieldm(j,l)=fieldm(j,l)+field(ij,l) + ENDDO + ENDDO + fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1) + ! Compute forcing + DO j=jjbu,jjeu + DO i=1,iip1 + ij=(j-1)*iip1+i + field(ij,l)=fieldm(j,l) + ENDDO + ENDDO + ENDDO + + END SUBROUTINE guide_zonave_u + + + SUBROUTINE guide_zonave_v(typ,hsize,vsize,field) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comgeom.h" + INCLUDE "comconst.h" + + ! input/output variables + INTEGER, INTENT(IN) :: typ + INTEGER, INTENT(IN) :: vsize + INTEGER, INTENT(IN) :: hsize + REAL, DIMENSION(ijb_v:ije_v,vsize), INTENT(INOUT) :: field + + ! Local variables + LOGICAL, SAVE :: first=.TRUE. + INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain + INTEGER :: i,j,l,ij + REAL, DIMENSION (iip1) :: lond ! longitude in Deg. + REAL, DIMENSION (jjb_v:jjev,vsize):: fieldm ! zon-averaged field + + IF (first) THEN + first=.FALSE. +!Compute domain for averaging + lond=rlonu*180./pi + imin(1)=1;imax(1)=iip1; + imin(2)=1;imax(2)=iip1; + IF (guide_reg) THEN + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(1)=i + IF (lond(i).LE.lon_max_g) imax(1)=i + ENDDO + lond=rlonv*180./pi + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(2)=i + IF (lond(i).LE.lon_max_g) imax(2)=i + ENDDO + ENDIF + ENDIF + + fieldm=0. + + DO l=1,vsize + ! Compute zonal average + DO j=jjbv,jjev + DO i=imin(typ),imax(typ) + ij=(j-1)*iip1+i + fieldm(j,l)=fieldm(j,l)+field(ij,l) + ENDDO + ENDDO + fieldm(:,l)=fieldm(:,l)/REAL(imax(typ)-imin(typ)+1) + ! Compute forcing + DO j=jjbv,jjev + DO i=1,iip1 + ij=(j-1)*iip1+i + field(ij,l)=fieldm(j,l) + ENDDO + ENDDO + ENDDO + + + END SUBROUTINE guide_zonave_v + +!======================================================================= + SUBROUTINE guide_interp(psi,teta) + USE parallel + USE mod_hallo + USE Bands + IMPLICIT NONE + + include "dimensions.h" + include "paramet.h" + include "comvert.h" + include "comgeom2.h" + include "comconst.h" + + REAL, DIMENSION (iip1,jjb_u:jje_u), INTENT(IN) :: psi ! Psol gcm + REAL, DIMENSION (iip1,jjb_u:jje_u,llm), INTENT(IN) :: teta ! Temp. Pot. gcm + + LOGICAL, SAVE :: first=.TRUE. + ! Variables pour niveaux pression: + REAL, DIMENSION (iip1,jjb_u:jje_u,nlevnc) :: plnc1,plnc2 !niveaux pression guidage + REAL, DIMENSION (iip1,jjb_u:jje_u,llm) :: plunc,plsnc !niveaux pression modele + REAL, DIMENSION (iip1,jjb_v:jje_v,llm) :: plvnc !niveaux pression modele + REAL, DIMENSION (iip1,jjb_u:jje_u,llmp1) :: p ! pression intercouches + REAL, DIMENSION (iip1,jjb_u:jje_u,llm) :: pls, pext ! var intermediaire + REAL, DIMENSION (iip1,jjb_u:jje_u,llm) :: pbarx + REAL, DIMENSION (iip1,jjb_v:jje_v,llm) :: pbary + ! Variables pour fonction Exner (P milieu couche) + REAL, DIMENSION (iip1,jjb_u:jje_u,llm) :: pk, pkf + REAL, DIMENSION (iip1,jjb_u:jje_u,llm) :: alpha, beta + REAL, DIMENSION (iip1,jjb_u:jje_u) :: pks + REAL :: unskap + ! Pression de vapeur saturante + REAL, DIMENSION (ijb_u:ije_u,llm) :: qsat + !Variables intermediaires interpolation + REAL, DIMENSION (iip1,jjb_u:jje_u,llm) :: zu1,zu2 + REAL, DIMENSION (iip1,jjb_v:jje_v,llm) :: zv1,zv2 + + INTEGER :: i,j,l,ij + TYPE(Request) :: Req + + print *,'Guide: conversion variables guidage' +! ----------------------------------------------------------------- +! Calcul des niveaux de pression champs guidage (pour T et Q) +! ----------------------------------------------------------------- + IF (guide_plevs.EQ.0) THEN + DO l=1,nlevnc + DO j=jjbu,jjeu + DO i=1,iip1 + plnc2(i,j,l)=apnc(l) + plnc1(i,j,l)=apnc(l) + ENDDO + ENDDO + ENDDO + ENDIF + + if (first) then + first=.FALSE. + print*,'Guide: verification ordre niveaux verticaux' + print*,'LMDZ :' + do l=1,llm + print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. & + +psi(1,jjeu)*(bp(l)+bp(l+1))/2. + enddo + print*,'Fichiers guidage' + SELECT CASE (guide_plevs) + CASE (0) + do l=1,nlevnc + print*,'PL(',l,')=',plnc2(1,jjbu,l) + enddo + CASE (1) + DO l=1,nlevnc + print*,'PL(',l,')=',apnc(l)+bpnc(l)*psnat2(i,jjbu) + ENDDO + CASE (2) + do l=1,nlevnc + print*,'PL(',l,')=',pnat2(1,jjbu,l) + enddo + END SELECT + print *,'inversion de l''ordre: invert_p=',invert_p + if (guide_u) then + do l=1,nlevnc + print*,'U(',l,')=',unat2(1,jjbu,l) + enddo + endif + if (guide_T) then + do l=1,nlevnc + print*,'T(',l,')=',tnat2(1,jjbu,l) + enddo + endif + endif + +! ----------------------------------------------------------------- +! Calcul niveaux pression modele +! ----------------------------------------------------------------- + +! .... Calcul de pls , pression au milieu des couches ,en Pascals + IF (guide_plevs.EQ.1) THEN + DO l=1,llm + DO j=jjbu,jjeu + DO i =1, iip1 + pls(i,j,l)=(ap(l)+ap(l+1))/2.+psi(i,j)*(bp(l)+bp(l+1))/2. + ENDDO + ENDDO + ENDDO + ELSE + CALL pression_loc( ijnb_u, ap, bp, psi, p ) + if (disvert_type==1) then + CALL exner_hyb_loc(ijnb_u,psi,p,alpha,beta,pks,pk,pkf) + else ! we assume that we are in the disvert_type==2 case + CALL exner_milieu_loc(ijnb_u,psi,p,beta,pks,pk,pkf) + endif + unskap=1./kappa + DO l = 1, llm + DO j=jjbu,jjeu + DO i =1, iip1 + pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap + ENDDO + ENDDO + ENDDO + ENDIF + +! calcul des pressions pour les grilles u et v + do l=1,llm + do j=jjbu,jjeu + do i=1,iip1 + pext(i,j,l)=pls(i,j,l)*aire(i,j) + enddo + enddo + enddo + + CALL Register_Hallo_u(pext,llm,1,2,2,1,Req) + CALL SendRequest(Req) + CALL WaitRequest(Req) + + call massbar_loc(pext, pbarx, pbary ) + do l=1,llm + do j=jjbu,jjeu + do i=1,iip1 + plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j) + plsnc(i,j,l)=pls(i,j,l) + enddo + enddo + enddo + do l=1,llm + do j=jjbv,jjev + do i=1,iip1 + plvnc(i,j,l)=pbary(i,j,l)/airev(i,j) + enddo + enddo + enddo + +! ----------------------------------------------------------------- +! Interpolation verticale champs guidage sur niveaux modele +! Conversion en variables gcm (ucov, vcov...) +! ----------------------------------------------------------------- + if (guide_P) then + do j=jjbu,jjeu + do i=1,iim + ij=(j-1)*iip1+i + psgui1(ij)=psnat1(i,j) + psgui2(ij)=psnat2(i,j) + enddo + psgui1(iip1*j)=psnat1(1,j) + psgui2(iip1*j)=psnat2(1,j) + enddo + endif + + IF (guide_T) THEN + ! Calcul des nouvelles valeurs des niveaux de pression du guidage + IF (guide_plevs.EQ.1) THEN + DO l=1,nlevnc + DO j=jjbu,jjeu + DO i=1,iip1 + plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j) + ENDDO + ENDDO + ENDDO + ELSE IF (guide_plevs.EQ.2) THEN + DO l=1,nlevnc + DO j=jjbu,jjeu + DO i=1,iip1 + plnc2(i,j,l)=pnat2(i,j,l) + plnc1(i,j,l)=pnat1(i,j,l) + ENDDO + ENDDO + ENDDO + ENDIF + + ! Interpolation verticale + CALL pres2lev(tnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm, & + plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p) + CALL pres2lev(tnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm, & + plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p) + + ! Conversion en variables GCM + do l=1,llm + do j=jjbu,jjeu + IF (guide_teta) THEN + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l) + tgui2(ij,l)=zu2(i,j,l) + enddo + ELSE + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l) + tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l) + enddo + ENDIF + tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l) + tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l) + enddo + if (pole_nord) then + do i=1,iip1 + tgui1(i,l)=tgui1(1,l) + tgui2(i,l)=tgui2(1,l) + enddo + endif + if (pole_sud) then + do i=1,iip1 + tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) + tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) + enddo + endif + enddo + ENDIF + + IF (guide_Q) THEN + ! Calcul des nouvelles valeurs des niveaux de pression du guidage + IF (guide_plevs.EQ.1) THEN + DO l=1,nlevnc + DO j=jjbu,jjeu + DO i=1,iip1 + plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j) + ENDDO + ENDDO + ENDDO + ELSE IF (guide_plevs.EQ.2) THEN + DO l=1,nlevnc + DO j=jjbu,jjeu + DO i=1,iip1 + plnc2(i,j,l)=pnat2(i,j,l) + plnc1(i,j,l)=pnat1(i,j,l) + ENDDO + ENDDO + ENDDO + ENDIF + + ! Interpolation verticale + CALL pres2lev(qnat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm, & + plnc1(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p) + CALL pres2lev(qnat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm, & + plnc2(:,jjbu:jjeu,:),plsnc(:,jjbu:jjeu,:),iip1,jjnu,invert_p) + + ! Conversion en variables GCM + ! On suppose qu'on a la bonne variable dans le fichier de guidage: + ! Hum.Rel si guide_hr, Hum.Spec. sinon. + do l=1,llm + do j=jjbu,jjeu + do i=1,iim + ij=(j-1)*iip1+i + qgui1(ij,l)=zu1(i,j,l) + qgui2(ij,l)=zu2(i,j,l) + enddo + qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l) + qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l) + enddo + if (pole_nord) then + do i=1,iip1 + qgui1(i,l)=qgui1(1,l) + qgui2(i,l)=qgui2(1,l) + enddo + endif + if (pole_nord) then + do i=1,iip1 + qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) + qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) + enddo + endif + enddo + IF (guide_hr) THEN + CALL q_sat(iip1*jjnu*llm,teta(:,jjbu:jjeu,:)*pk(:,jjbu:jjeu,:)/cpp, & + plsnc(:,jjbu:jjeu,:),qsat(ijbu:ijeu,:)) + qgui1(ijbu:ijeu,:)=qgui1(ijbu:ijeu,:)*qsat(ijbu:ijeu,:)*0.01 !hum. rel. en % + qgui2(ijbu:ijeu,:)=qgui2(ijbu:ijeu,:)*qsat(ijbu:ijeu,:)*0.01 + ENDIF + ENDIF + + IF (guide_u) THEN + ! Calcul des nouvelles valeurs des niveaux de pression du guidage + IF (guide_plevs.EQ.1) THEN + DO l=1,nlevnc + DO j=jjbu,jjeu + DO i=1,iim + plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha1p2(i,j) & + & +psnat2(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha1p2(i,j) & + & +psnat1(i+1,j)*aire(i+1,j)*alpha3p4(i+1,j))/aireu(i,j) + ENDDO + plnc2(iip1,j,l)=plnc2(1,j,l) + plnc1(iip1,j,l)=plnc1(1,j,l) + ENDDO + ENDDO + ELSE IF (guide_plevs.EQ.2) THEN + DO l=1,nlevnc + DO j=jjbu,jjeu + DO i=1,iim + plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha1p2(i,j) & + & +pnat2(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j) + plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha1p2(i,j) & + & +pnat1(i+1,j,l)*aire(i,j)*alpha3p4(i+1,j))/aireu(i,j) + ENDDO + plnc2(iip1,j,l)=plnc2(1,j,l) + plnc1(iip1,j,l)=plnc1(1,j,l) + ENDDO + ENDDO + ENDIF + + ! Interpolation verticale + CALL pres2lev(unat1(:,jjbu:jjeu,:),zu1(:,jjbu:jjeu,:),nlevnc,llm, & + plnc1(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p) + CALL pres2lev(unat2(:,jjbu:jjeu,:),zu2(:,jjbu:jjeu,:),nlevnc,llm, & + plnc2(:,jjbu:jjeu,:),plunc(:,jjbu:jjeu,:),iip1,jjnu,invert_p) + + ! Conversion en variables GCM + do l=1,llm + do j=jjbu,jjeu + do i=1,iim + ij=(j-1)*iip1+i + ugui1(ij,l)=zu1(i,j,l)*cu(i,j) + ugui2(ij,l)=zu2(i,j,l)*cu(i,j) + enddo + ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l) + ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l) + enddo + if (pole_nord) then + do i=1,iip1 + ugui1(i,l)=0. + ugui2(i,l)=0. + enddo + endif + if (pole_sud) then + do i=1,iip1 + ugui1(ip1jm+i,l)=0. + ugui2(ip1jm+i,l)=0. + enddo + endif + enddo + ENDIF + + IF (guide_v) THEN + ! Calcul des nouvelles valeurs des niveaux de pression du guidage + IF (guide_plevs.EQ.1) THEN + CALL Register_Hallo_u(psnat1,1,1,2,2,1,Req) + CALL Register_Hallo_u(psnat2,1,1,2,2,1,Req) + CALL SendRequest(Req) + CALL WaitRequest(Req) + DO l=1,nlevnc + DO j=jjbv,jjev + DO i=1,iip1 + plnc2(i,j,l)=apnc(l)+bpnc(l)*(psnat2(i,j)*aire(i,j)*alpha2p3(i,j) & + & +psnat2(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*(psnat1(i,j)*aire(i,j)*alpha2p3(i,j) & + & +psnat1(i,j+1)*aire(i,j+1)*alpha1p4(i,j+1))/airev(i,j) + ENDDO + ENDDO + ENDDO + ELSE IF (guide_plevs.EQ.2) THEN + CALL Register_Hallo_u(pnat1,llm,1,2,2,1,Req) + CALL Register_Hallo_u(pnat2,llm,1,2,2,1,Req) + CALL SendRequest(Req) + CALL WaitRequest(Req) + DO l=1,nlevnc + DO j=jjbv,jjev + DO i=1,iip1 + plnc2(i,j,l)=(pnat2(i,j,l)*aire(i,j)*alpha2p3(i,j) & + & +pnat2(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j) + plnc1(i,j,l)=(pnat1(i,j,l)*aire(i,j)*alpha2p3(i,j) & + & +pnat1(i,j+1,l)*aire(i,j)*alpha1p4(i,j+1))/airev(i,j) + ENDDO + ENDDO + ENDDO + ENDIF + ! Interpolation verticale + CALL pres2lev(vnat1(:,jjbv:jjev,:),zv1(:,jjbv:jjev,:),nlevnc,llm, & + plnc1(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p) + CALL pres2lev(vnat2(:,jjbv:jjev,:),zv2(:,jjbv:jjev,:),nlevnc,llm, & + plnc2(:,jjbv:jjev,:),plvnc(:,jjbv:jjev,:),iip1,jjnv,invert_p) + ! Conversion en variables GCM + do l=1,llm + do j=jjbv,jjev + do i=1,iim + ij=(j-1)*iip1+i + vgui1(ij,l)=zv1(i,j,l)*cv(i,j) + vgui2(ij,l)=zv2(i,j,l)*cv(i,j) + enddo + vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l) + vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l) + enddo + enddo + ENDIF + + + END SUBROUTINE guide_interp + +!======================================================================= + SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha) + +! Calcul des constantes de rappel alpha (=1/tau) + + implicit none + + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "comgeom2.h" + include "serre.h" + +! input arguments : + INTEGER, INTENT(IN) :: typ ! u(2),v(3), ou scalaire(1) + INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon + REAL, INTENT(IN) :: factt ! pas de temps en fraction de jour + REAL, INTENT(IN) :: taumin,taumax +! output arguments: + REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha + +! local variables: + LOGICAL, SAVE :: first=.TRUE. + REAL, SAVE :: gamma,dxdy_min,dxdy_max + REAL, DIMENSION (iip1,jjp1) :: zdx,zdy + REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu + REAL, DIMENSION (iip1,jjm) :: dxdyv + real dxdy_ + real zlat,zlon + real alphamin,alphamax,xi + integer i,j,ilon,ilat + + + alphamin=factt/taumax + alphamax=factt/taumin + IF (guide_reg.OR.guide_add) THEN + alpha=alphamax +!----------------------------------------------------------------------- +! guide_reg: alpha=alpha_min dans region, 0. sinon. +!----------------------------------------------------------------------- + IF (guide_reg) THEN + do j=1,pjm + do i=1,pim + if (typ.eq.2) then + zlat=rlatu(j)*180./pi + zlon=rlonu(i)*180./pi + elseif (typ.eq.1) then + zlat=rlatu(j)*180./pi + zlon=rlonv(i)*180./pi + elseif (typ.eq.3) then + zlat=rlatv(j)*180./pi + zlon=rlonv(i)*180./pi + endif + alpha(i,j)=alphamax/16.* & + (1.+tanh((zlat-lat_min_g)/tau_lat))* & + (1.+tanh((lat_max_g-zlat)/tau_lat))* & + (1.+tanh((zlon-lon_min_g)/tau_lon))* & + (1.+tanh((lon_max_g-zlon)/tau_lon)) + enddo + enddo + ENDIF + ELSE +!----------------------------------------------------------------------- +! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom. +!----------------------------------------------------------------------- +!Calcul de l'aire des mailles + do j=2,jjm + do i=2,iip1 + zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j)) + enddo + zdx(1,j)=zdx(iip1,j) + enddo + do j=2,jjm + do i=1,iip1 + zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j)) + enddo + enddo + do i=1,iip1 + zdx(i,1)=zdx(i,2) + zdx(i,jjp1)=zdx(i,jjm) + zdy(i,1)=zdy(i,2) + zdy(i,jjp1)=zdy(i,jjm) + enddo + do j=1,jjp1 + do i=1,iip1 + dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j)) + enddo + enddo + IF (typ.EQ.2) THEN + do j=1,jjp1 + do i=1,iim + dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j)) + enddo + dxdyu(iip1,j)=dxdyu(1,j) + enddo + ENDIF + IF (typ.EQ.3) THEN + do j=1,jjm + do i=1,iip1 + dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1)) + enddo + enddo + ENDIF +! Premier appel: calcul des aires min et max et de gamma. + IF (first) THEN + first=.FALSE. + ! coordonnees du centre du zoom + CALL coordij(clon,clat,ilon,ilat) + ! aire de la maille au centre du zoom + dxdy_min=dxdys(ilon,ilat) + ! dxdy maximale de la maille + dxdy_max=0. + do j=1,jjp1 + do i=1,iip1 + dxdy_max=max(dxdy_max,dxdys(i,j)) + enddo + enddo + ! Calcul de gamma + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + print*,'ATTENTION modele peu zoome' + print*,'ATTENTION on prend une constante de guidage cste' + gamma=0. + else + gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min) + print*,'gamma=',gamma + if (gamma.lt.1.e-5) then + print*,'gamma =',gamma,'<1e-5' + stop + endif + gamma=log(0.5)/log(gamma) + if (gamma4) then + gamma=min(gamma,4.) + endif + print*,'gamma=',gamma + endif + ENDIF !first + + do j=1,pjm + do i=1,pim + if (typ.eq.1) then + dxdy_=dxdys(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.2) then + dxdy_=dxdyu(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.3) then + dxdy_=dxdyv(i,j) + zlat=rlatv(j)*180./pi + endif + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin + alpha(i,j)=alphamin + else + xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma + xi=min(xi,1.) + if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then + alpha(i,j)=xi*alphamin+(1.-xi)*alphamax + else + alpha(i,j)=0. + endif + endif + enddo + enddo + ENDIF ! guide_reg + + END SUBROUTINE tau2alpha + +!======================================================================= + SUBROUTINE guide_read(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidp,varidp + INTEGER, SAVE :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'guide_read' + abort_message='pb in guide_read' + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Ap et Bp si Niveaux de pression hybrides + if (guide_plevs.EQ.1) then + print *,'Lecture du guidage sur niveaux modele' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Pression si guidage sur niveaux P variables + if (guide_plevs.EQ.2) then + rcode = nf90_open('P.nc', nf90_nowrite, ncidp) + rcode = nf90_inq_varid(ncidp, 'PRES', varidp) + print*,'ncidp,varidp',ncidp,varidp + if (ncidpl.eq.-99) ncidpl=ncidp + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_plevs.EQ.1)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (guide_plevs.EQ.0) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + IF (guide_plevs.EQ.1) THEN +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + ELSEIF (guide_plevs.EQ.0) THEN +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + ENDIF + first=.FALSE. + ENDIF ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=jjb_u + start(3)=1 + start(4)=timestep + + count(1)=iip1 + count(2)=jjnb_u + count(3)=nlevnc + count(4)=1 + + IF (invert_y) start(2)=jjp1-jje_u+1 +! Pression + if (guide_plevs.EQ.2) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,pnat2) +#else + status=NF_GET_VARA_REAL(ncidp,varidp,start,count,pnat2) +#endif + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2) + ENDIF + endif + +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2) +#endif + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_u,nlevnc,unat2) + ENDIF + + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2) +#endif + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2) + ENDIF + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2) +#endif + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2) + ENDIF + + endif + +! Vent meridien + if (guide_v) then + start(2)=jjb_v + count(2)=jjnb_v + IF (invert_y) start(2)=jjm-jje_v+1 + +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2) +#endif + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2) + ENDIF + endif + +! Pression de surface + if ((guide_P).OR.(guide_plevs.EQ.1)) then + start(2)=jjb_u + start(3)=timestep + start(4)=0 + count(2)=jjnb_u + count(3)=1 + count(4)=0 + IF (invert_y) start(2)=jjp1-jje_u+1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2) +#endif + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_u,1,psnat2) + ENDIF + endif + + END SUBROUTINE guide_read + +!======================================================================= + SUBROUTINE guide_read2D(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidp,varidp + INTEGER, SAVE :: ncidQ,varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode +! Variables for 3D extension: + REAL, DIMENSION (jjb_u:jje_u,llm) :: zu + REAL, DIMENSION (jjb_v:jje_v,llm) :: zv + INTEGER :: i + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'guide_read' + abort_message='pb in guide_read2D' + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Ap et Bp si niveaux de pression hybrides + if (guide_plevs.EQ.1) then + print *,'Lecture du guidage sur niveaux mod�le' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Pression + if (guide_plevs.EQ.2) then + rcode = nf90_open('P.nc', nf90_nowrite, ncidp) + rcode = nf90_inq_varid(ncidp, 'PRES', varidp) + print*,'ncidp,varidp',ncidp,varidp + if (ncidpl.eq.-99) ncidpl=ncidp + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_plevs.EQ.1)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (guide_plevs.EQ.0) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + if (guide_plevs.EQ.1) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + elseif (guide_plevs.EQ.0) THEN +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + endif + first=.FALSE. + endif ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=jjb_u + start(3)=1 + start(4)=timestep + + count(1)=1 + count(2)=jjnb_u + count(3)=nlevnc + count(4)=1 + + IF (invert_y) start(2)=jjp1-jje_u+1 +! Pression + if (guide_plevs.EQ.2) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidp,varidp,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidp,varidp,start,count,zu) +#endif + DO i=1,iip1 + pnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_u,nlevnc,pnat2) + ENDIF + endif +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu) +#endif + DO i=1,iip1 + unat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_u,nlevnc,unat2) + ENDIF + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu) +#endif + DO i=1,iip1 + tnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_u,nlevnc,tnat2) + ENDIF + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu) +#endif + DO i=1,iip1 + qnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_u,nlevnc,qnat2) + ENDIF + endif + +! Vent meridien + if (guide_v) then + start(2)=jjb_v + count(2)=jjnb_v + IF (invert_y) start(2)=jjm-jje_v+1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv) +#endif + DO i=1,iip1 + vnat2(i,:,:)=zv(:,:) + ENDDO + + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_v,nlevnc,vnat2) + ENDIF + endif + +! Pression de surface + if ((guide_P).OR.(guide_plevs.EQ.1)) then + start(2)=jjb_u + start(3)=timestep + start(4)=0 + count(2)=jjnb_u + count(3)=1 + count(4)=0 + IF (invert_y) start(2)=jjp1-jje_u+1 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1)) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1)) +#endif + DO i=1,iip1 + psnat2(i,:)=zu(:,1) + ENDDO + + IF (invert_y) THEN +! PRINT*,"Invertion impossible actuellement" +! CALL abort_gcm(modname,abort_message,1) + CALL invert_lat(iip1,jjnb_u,1,psnat2) + ENDIF + endif + + END SUBROUTINE guide_read2D + +!======================================================================= + SUBROUTINE guide_out(varname,hsize,vsize,field,factt) + USE parallel + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + INCLUDE "comgeom2.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + CHARACTER, INTENT(IN) :: varname + INTEGER, INTENT (IN) :: hsize,vsize + REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field + REAL, INTENT (IN) :: factt + + ! Variables locales + INTEGER, SAVE :: timestep=0 + ! Identites fichier netcdf + INTEGER :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev + INTEGER :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev + INTEGER, DIMENSION (3) :: dim3 + INTEGER, DIMENSION (4) :: dim4,count,start + INTEGER :: ierr, varid + + CALL gather_field(field,iip1*hsize,vsize,0) + + IF (mpi_rank /= 0) RETURN + + print *,'Guide: output timestep',timestep,'var ',varname + IF (timestep.EQ.0) THEN +! ---------------------------------------------- +! initialisation fichier de sortie +! ---------------------------------------------- +! Ouverture du fichier + ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid) +! Definition des dimensions + ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) + ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) + ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) + ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) + ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev) + ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim) + +! Creation des variables dimensions + ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu) + ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv) + ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu) + ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv) + ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev) + ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu) + ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv) + + ierr=NF_ENDDEF(nid) + +! Enregistrement des variables dimensions +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv) +#else + ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu) + ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv) +#endif +! -------------------------------------------------------------------- +! Cr�ation des variables sauvegard�es +! -------------------------------------------------------------------- + ierr = NF_REDEF(nid) +! Pressure (GCM) + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"P",NF_FLOAT,4,dim4,varid) +! Surface pressure (guidage) + IF (guide_P) THEN + dim3=(/id_lonv,id_latu,id_tim/) + ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid) + ENDIF +! Zonal wind + IF (guide_u) THEN + dim4=(/id_lonu,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid) + ENDIF +! Merid. wind + IF (guide_v) THEN + dim4=(/id_lonv,id_latv,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid) + ENDIF +! Pot. Temperature + IF (guide_T) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid) + ENDIF +! Specific Humidity + IF (guide_Q) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid) + ENDIF + + ierr = NF_ENDDEF(nid) + ierr = NF_CLOSE(nid) + ENDIF ! timestep=0 + +! -------------------------------------------------------------------- +! Enregistrement du champ +! -------------------------------------------------------------------- + + ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid) + + SELECT CASE (varname) + CASE ("P") + timestep=timestep+1 + ierr = NF_INQ_VARID(nid,"P",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("SP") + ierr = NF_INQ_VARID(nid,"ps",varid) + start=(/1,1,timestep,0/) + count=(/iip1,jjp1,1,0/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt) +#endif + CASE ("U") + ierr = NF_INQ_VARID(nid,"ucov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt) +#endif + CASE ("V") + ierr = NF_INQ_VARID(nid,"vcov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjm,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt) +#endif + CASE ("T") + ierr = NF_INQ_VARID(nid,"teta",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt) +#endif + CASE ("Q") + ierr = NF_INQ_VARID(nid,"q",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt) +#endif + END SELECT + + ierr = NF_CLOSE(nid) + + END SUBROUTINE guide_out + + +!=========================================================================== + subroutine correctbid(iim,nl,x) + integer iim,nl + real x(iim+1,nl) + integer i,l + real zz + + do l=1,nl + do i=2,iim-1 + if(abs(x(i,l)).gt.1.e10) then + zz=0.5*(x(i-1,l)+x(i+1,l)) + print*,'correction ',i,l,x(i,l),zz + x(i,l)=zz + endif + enddo + enddo + return + end subroutine correctbid + +!=========================================================================== +END MODULE guide_loc_mod Index: /LMDZ5/trunk/libf/dyn3dmem/guide_p_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/guide_p_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/guide_p_mod.F90 (revision 1632) @@ -0,0 +1,1646 @@ +! +! $Id$ +! +MODULE guide_p_mod + +!======================================================================= +! Auteur: F.Hourdin +! F. Codron 01/09 +!======================================================================= + + USE getparam + USE Write_Field_p + use netcdf, only: nf90_nowrite, nf90_open, nf90_inq_varid, nf90_close + + IMPLICIT NONE + +! --------------------------------------------- +! Declarations des cles logiques et parametres +! --------------------------------------------- + INTEGER, PRIVATE, SAVE :: iguide_read,iguide_int,iguide_sav + INTEGER, PRIVATE, SAVE :: nlevnc + LOGICAL, PRIVATE, SAVE :: guide_u,guide_v,guide_T,guide_Q,guide_P + LOGICAL, PRIVATE, SAVE :: guide_hr,guide_teta + LOGICAL, PRIVATE, SAVE :: guide_BL,guide_reg,guide_add,gamma4,guide_zon + LOGICAL, PRIVATE, SAVE :: guide_modele,invert_p,invert_y,ini_anal + LOGICAL, PRIVATE, SAVE :: guide_2D,guide_sav + + REAL, PRIVATE, SAVE :: tau_min_u,tau_max_u + REAL, PRIVATE, SAVE :: tau_min_v,tau_max_v + REAL, PRIVATE, SAVE :: tau_min_T,tau_max_T + REAL, PRIVATE, SAVE :: tau_min_Q,tau_max_Q + REAL, PRIVATE, SAVE :: tau_min_P,tau_max_P + + REAL, PRIVATE, SAVE :: lat_min_g,lat_max_g + REAL, PRIVATE, SAVE :: lon_min_g,lon_max_g + REAL, PRIVATE, SAVE :: tau_lon,tau_lat + + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_u,alpha_v + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_T,alpha_Q + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: alpha_P,alpha_pcor + +! --------------------------------------------- +! Variables de guidage +! --------------------------------------------- +! Variables des fichiers de guidage + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: unat1,unat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: vnat1,vnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: tnat1,tnat2 + REAL, ALLOCATABLE, DIMENSION(:,:,:), PRIVATE, SAVE :: qnat1,qnat2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: psnat1,psnat2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: apnc,bpnc +! Variables aux dimensions du modele + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: ugui1,ugui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: vgui1,vgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: tgui1,tgui2 + REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE :: qgui1,qgui2 + REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE :: psgui1,psgui2 + + INTEGER,SAVE,PRIVATE :: ijb_u,ijb_v,ije_u,ije_v,ijn_u,ijn_v + INTEGER,SAVE,PRIVATE :: jjb_u,jjb_v,jje_u,jje_v,jjn_u,jjn_v + + +CONTAINS +!======================================================================= + + SUBROUTINE guide_init + + USE control_mod + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + + INTEGER :: error,ncidpl,rid,rcod + CHARACTER (len = 80) :: abort_message + CHARACTER (len = 20) :: modname = 'guide_init' + +! --------------------------------------------- +! Lecture des parametres: +! --------------------------------------------- +! Variables guidees + CALL getpar('guide_u',.true.,guide_u,'guidage de u') + CALL getpar('guide_v',.true.,guide_v,'guidage de v') + CALL getpar('guide_T',.true.,guide_T,'guidage de T') + CALL getpar('guide_P',.true.,guide_P,'guidage de P') + CALL getpar('guide_Q',.true.,guide_Q,'guidage de Q') + CALL getpar('guide_hr',.true.,guide_hr,'guidage de Q par H.R') + CALL getpar('guide_teta',.false.,guide_teta,'guidage de T par Teta') + + CALL getpar('guide_add',.false.,guide_add,'for�age constant?') + CALL getpar('guide_zon',.false.,guide_zon,'guidage moy zonale') + +! Constantes de rappel. Unite : fraction de jour + CALL getpar('tau_min_u',0.02,tau_min_u,'Cste de rappel min, u') + CALL getpar('tau_max_u', 10.,tau_max_u,'Cste de rappel max, u') + CALL getpar('tau_min_v',0.02,tau_min_v,'Cste de rappel min, v') + CALL getpar('tau_max_v', 10.,tau_max_v,'Cste de rappel max, v') + CALL getpar('tau_min_T',0.02,tau_min_T,'Cste de rappel min, T') + CALL getpar('tau_max_T', 10.,tau_max_T,'Cste de rappel max, T') + CALL getpar('tau_min_Q',0.02,tau_min_Q,'Cste de rappel min, Q') + CALL getpar('tau_max_Q', 10.,tau_max_Q,'Cste de rappel max, Q') + CALL getpar('tau_min_P',0.02,tau_min_P,'Cste de rappel min, P') + CALL getpar('tau_max_P', 10.,tau_max_P,'Cste de rappel max, P') + CALL getpar('gamma4',.false.,gamma4,'Zone sans rappel elargie') + CALL getpar('guide_BL',.true.,guide_BL,'guidage dans C.Lim') + +! Sauvegarde du for�age + CALL getpar('guide_sav',.false.,guide_sav,'sauvegarde guidage') + CALL getpar('iguide_sav',4,iguide_sav,'freq. sauvegarde guidage') + ! frequences f>0: fx/jour; f<0: tous les f jours; f=0: 1 seule fois. + IF (iguide_sav.GT.0) THEN + iguide_sav=day_step/iguide_sav + ELSE + iguide_sav=day_step*iguide_sav + ENDIF + +! Guidage regional seulement (sinon constant ou suivant le zoom) + CALL getpar('guide_reg',.false.,guide_reg,'guidage regional') + CALL getpar('lat_min_g',-90.,lat_min_g,'Latitude mini guidage ') + CALL getpar('lat_max_g', 90.,lat_max_g,'Latitude maxi guidage ') + CALL getpar('lon_min_g',-180.,lon_min_g,'longitude mini guidage ') + CALL getpar('lon_max_g', 180.,lon_max_g,'longitude maxi guidage ') + CALL getpar('tau_lat', 5.,tau_lat,'raideur lat guide regional ') + CALL getpar('tau_lon', 5.,tau_lon,'raideur lon guide regional ') + +! Parametres pour lecture des fichiers + CALL getpar('iguide_read',4,iguide_read,'freq. lecture guidage') + CALL getpar('iguide_int',4,iguide_int,'freq. lecture guidage') + IF (iguide_int.GT.0) THEN + iguide_int=day_step/iguide_int + ELSE + iguide_int=day_step*iguide_int + ENDIF + CALL getpar('guide_modele',.false.,guide_modele,'guidage niveaux modele') + CALL getpar('ini_anal',.false.,ini_anal,'Etat initial = analyse') + CALL getpar('guide_invertp',.true.,invert_p,'niveaux p inverses') + CALL getpar('guide_inverty',.true.,invert_y,'inversion N-S') + CALL getpar('guide_2D',.false.,guide_2D,'fichier guidage lat-P') + +! --------------------------------------------- +! Determination du nombre de niveaux verticaux +! des fichiers guidage +! --------------------------------------------- + ncidpl=-99 + if (guide_modele) then + if (ncidpl.eq.-99) rcod=nf90_open('apbp.nc',Nf90_NOWRITe, ncidpl) + else + if (guide_u) then + if (ncidpl.eq.-99) rcod=nf90_open('u.nc',Nf90_NOWRITe,ncidpl) + elseif (guide_v) then + if (ncidpl.eq.-99) rcod=nf90_open('v.nc',nf90_nowrite,ncidpl) + elseif (guide_T) then + if (ncidpl.eq.-99) rcod=nf90_open('T.nc',nf90_nowrite,ncidpl) + elseif (guide_Q) then + if (ncidpl.eq.-99) rcod=nf90_open('hur.nc',nf90_nowrite, ncidpl) + endif + endif + error=NF_INQ_DIMID(ncidpl,'LEVEL',rid) + IF (error.NE.NF_NOERR) error=NF_INQ_DIMID(ncidpl,'PRESSURE',rid) + IF (error.NE.NF_NOERR) THEN + print *,'Guide: probleme lecture niveaux pression' + CALL abort_gcm(modname,abort_message,1) + ENDIF + error=NF_INQ_DIMLEN(ncidpl,rid,nlevnc) + print *,'Guide: nombre niveaux vert. nlevnc', nlevnc + rcod = nf90_close(ncidpl) + +! --------------------------------------------- +! Allocation des variables +! --------------------------------------------- + abort_message='pb in allocation guide' + + ALLOCATE(apnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(bpnc(nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + apnc=0.;bpnc=0. + + ALLOCATE(alpha_pcor(llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_u(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_v(ip1jm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_T(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_Q(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(alpha_P(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + alpha_u=0.;alpha_v=0;alpha_T=0;alpha_Q=0;alpha_P=0 + + IF (guide_u) THEN + ALLOCATE(unat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(unat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(ugui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + unat1=0.;unat2=0.;ugui1=0.;ugui2=0. + ENDIF + + IF (guide_T) THEN + ALLOCATE(tnat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tnat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(tgui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + tnat1=0.;tnat2=0.;tgui1=0.;tgui2=0. + ENDIF + + IF (guide_Q) THEN + ALLOCATE(qnat1(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui1(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qnat2(iip1,jjp1,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(qgui2(ip1jmp1,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + qnat1=0.;qnat2=0.;qgui1=0.;qgui2=0. + ENDIF + + IF (guide_v) THEN + ALLOCATE(vnat1(iip1,jjm,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui1(ip1jm,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vnat2(iip1,jjm,nlevnc), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(vgui2(ip1jm,llm), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + vnat1=0.;vnat2=0.;vgui1=0.;vgui2=0. + ENDIF + + IF (guide_P.OR.guide_modele) THEN + ALLOCATE(psnat1(iip1,jjp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psnat2(iip1,jjp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psnat1=0.;psnat2=0.; + ENDIF + IF (guide_P) THEN + ALLOCATE(psgui2(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + ALLOCATE(psgui1(ip1jmp1), stat = error) + IF (error /= 0) CALL abort_gcm(modname,abort_message,1) + psgui1=0.;psgui2=0. + ENDIF + +! --------------------------------------------- +! Lecture du premier etat de guidage. +! --------------------------------------------- + IF (guide_2D) THEN + CALL guide_read2D(1) + ELSE + CALL guide_read(1) + ENDIF + IF (guide_v) vnat1=vnat2 + IF (guide_u) unat1=unat2 + IF (guide_T) tnat1=tnat2 + IF (guide_Q) qnat1=qnat2 + IF (guide_P.OR.guide_modele) psnat1=psnat2 + + END SUBROUTINE guide_init + +!======================================================================= + SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps) + use parallel + USE control_mod + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + INTEGER, INTENT(IN) :: itau !pas de temps + REAL, DIMENSION (ip1jmp1,llm), INTENT(INOUT) :: ucov,teta,q,masse + REAL, DIMENSION (ip1jm,llm), INTENT(INOUT) :: vcov + REAL, DIMENSION (ip1jmp1), INTENT(INOUT) :: ps + + ! Variables locales + LOGICAL, SAVE :: first=.TRUE. + LOGICAL :: f_out ! sortie guidage + REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage + REAL, DIMENSION (ip1jmp1,llm) :: p ! besoin si guide_P + ! Compteurs temps: + INTEGER, SAVE :: step_rea,count_no_rea,itau_test ! lecture guidage + REAL :: ditau, dday_step + REAL :: tau,reste ! position entre 2 etats de guidage + REAL, SAVE :: factt ! pas de temps en fraction de jour + + INTEGER :: l + + ijb_u=ij_begin ; ije_u=ij_end ; ijn_u=ije_u-ijb_u+1 + jjb_u=jj_begin ; jje_u=jj_end ; jjn_u=jje_u-jjb_u+1 + ijb_v=ij_begin ; ije_v=ij_end ; ijn_v=ije_v-ijb_v+1 + jjb_v=jj_begin ; jje_v=jj_end ; jjn_v=jje_v-jjb_v+1 + IF (pole_sud) THEN + ije_v=ij_end-iip1 + jje_v=jj_end-1 + ijn_v=ije_v-ijb_v+1 + jjn_v=jje_v-jjb_v+1 + ENDIF + + + + PRINT *,'---> on rentre dans guide_main' +! CALL AllGather_Field(ucov,ip1jmp1,llm) +! CALL AllGather_Field(vcov,ip1jm,llm) +! CALL AllGather_Field(teta,ip1jmp1,llm) +! CALL AllGather_Field(ps,ip1jmp1,1) +! CALL AllGather_Field(q,ip1jmp1,llm) + +!----------------------------------------------------------------------- +! Initialisations au premier passage +!----------------------------------------------------------------------- + + IF (first) THEN + first=.FALSE. + CALL guide_init + itau_test=1001 + step_rea=1 + count_no_rea=0 +! Calcul des constantes de rappel + factt=dtvr*iperiod/daysec + call tau2alpha(3,iip1,jjm ,factt,tau_min_v,tau_max_v,alpha_v) + call tau2alpha(2,iip1,jjp1,factt,tau_min_u,tau_max_u,alpha_u) + call tau2alpha(1,iip1,jjp1,factt,tau_min_T,tau_max_T,alpha_T) + call tau2alpha(1,iip1,jjp1,factt,tau_min_P,tau_max_P,alpha_P) + call tau2alpha(1,iip1,jjp1,factt,tau_min_Q,tau_max_Q,alpha_Q) +! correction de rappel dans couche limite + if (guide_BL) then + alpha_pcor(:)=1. + else + do l=1,llm + alpha_pcor(l)=(1.+tanh((0.85-presnivs(l)/preff)/0.05))/2. + enddo + endif +! ini_anal: etat initial egal au guidage + IF (ini_anal) THEN + CALL guide_interp(ps,teta) + IF (guide_u) ucov(ijb_u:ije_u,:)=ugui2(ijb_u:ije_u,:) + IF (guide_v) vcov(ijb_v:ije_v,:)=ugui2(ijb_v:ije_v,:) + IF (guide_T) teta(ijb_u:ije_u,:)=tgui2(ijb_u:ije_u,:) + IF (guide_Q) q(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:) + IF (guide_P) THEN + ps(ijb_u:ije_u)=psgui2(ijb_u:ije_u) + CALL pression_p(ip1jmp1,ap,bp,ps,p) + CALL massdair_p(p,masse) + ENDIF + RETURN + ENDIF +! Verification structure guidage + IF (guide_u) THEN + CALL writefield_p('unat',unat1) + CALL writefield_p('ucov',RESHAPE(ucov,(/iip1,jjp1,llm/))) + ENDIF + IF (guide_T) THEN + CALL writefield_p('tnat',tnat1) + CALL writefield_p('teta',RESHAPE(teta,(/iip1,jjp1,llm/))) + ENDIF + + ENDIF !first + +!----------------------------------------------------------------------- +! Lecture des fichiers de guidage ? +!----------------------------------------------------------------------- + IF (iguide_read.NE.0) THEN + ditau=real(itau) + dday_step=real(day_step) + IF (iguide_read.LT.0) THEN + tau=ditau/dday_step/ REAL(iguide_read) + ELSE + tau= REAL(iguide_read)*ditau/dday_step + ENDIF + reste=tau-AINT(tau) + IF (reste.EQ.0.) THEN + IF (itau_test.EQ.itau) THEN + write(*,*)'deuxieme passage de advreel a itau=',itau + stop + ELSE + IF (guide_v) vnat1(jjb_v:jje_v,:,:)=vnat2(jjb_v:jje_v,:,:) + IF (guide_u) unat1(jjb_u:jje_u,:,:)=unat2(jjb_u:jje_u,:,:) + IF (guide_T) tnat1(jjb_u:jje_u,:,:)=tnat2(jjb_u:jje_u,:,:) + IF (guide_Q) qnat1(jjb_u:jje_u,:,:)=qnat2(jjb_u:jje_u,:,:) + IF (guide_P.OR.guide_modele) psnat1(jjb_u:jje_u,:)=psnat2(jjb_u:jje_u,:) + step_rea=step_rea+1 + itau_test=itau + print*,'Lecture fichiers guidage, pas ',step_rea, & + 'apres ',count_no_rea,' non lectures' + IF (guide_2D) THEN + CALL guide_read2D(step_rea) + ELSE + CALL guide_read(step_rea) + ENDIF + count_no_rea=0 + ENDIF + ELSE + count_no_rea=count_no_rea+1 + + ENDIF + ENDIF !iguide_read=0 + +!----------------------------------------------------------------------- +! Interpolation et conversion des champs de guidage +!----------------------------------------------------------------------- + IF (MOD(itau,iguide_int).EQ.0) THEN + CALL guide_interp(ps,teta) + ENDIF +! Repartition entre 2 etats de guidage + IF (iguide_read.NE.0) THEN + tau=reste + ELSE + tau=1. + ENDIF + +!----------------------------------------------------------------------- +! Ajout des champs de guidage +!----------------------------------------------------------------------- +! Sauvegarde du guidage? + f_out=((MOD(itau,iguide_sav).EQ.0).AND.guide_sav) + IF (f_out) CALL guide_out("S",jjp1,1,ps) + + if (guide_u) then + if (guide_add) then + f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:) + else + f_add(ijb_u:ije_u,:)=(1.-tau)*ugui1(ijb_u:ije_u,:)+tau*ugui2(ijb_u:ije_u,:)-ucov(ijb_u:ije_u,:) + endif + + if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u) + IF (f_out) CALL guide_out("U",jjp1,llm,f_add/factt) + ucov(ijb_u:ije_u,:)=ucov(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) + endif + + if (guide_T) then + if (guide_add) then + f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:) + else + f_add(ijb_u:ije_u,:)=(1.-tau)*tgui1(ijb_u:ije_u,:)+tau*tgui2(ijb_u:ije_u,:)-teta(ijb_u:ije_u,:) + endif + if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T) + IF (f_out) CALL guide_out("T",jjp1,llm,f_add/factt) + teta(ijb_u:ije_u,:)=teta(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) + endif + + if (guide_P) then + if (guide_add) then + f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u) + else + f_add(ijb_u:ije_u,1)=(1.-tau)*psgui1(ijb_u:ije_u)+tau*psgui2(ijb_u:ije_u)-ps(ijb_u:ije_u) + endif + if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1)) + CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P) + IF (f_out) CALL guide_out("P",jjp1,1,f_add(1:ip1jmp1,1)/factt) + ps(ijb_u:ije_u)=ps(ijb_u:ije_u)+f_add(ijb_u:ije_u,1) + CALL pression_p(ip1jmp1,ap,bp,ps,p) + CALL massdair_p(p,masse) + endif + + if (guide_Q) then + if (guide_add) then + f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:) + else + f_add(ijb_u:ije_u,:)=(1.-tau)*qgui1(ijb_u:ije_u,:)+tau*qgui2(ijb_u:ije_u,:)-q(ijb_u:ije_u,:) + endif + if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) + CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q) + IF (f_out) CALL guide_out("Q",jjp1,llm,f_add/factt) + q(ijb_u:ije_u,:)=q(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) + endif + + if (guide_v) then + if (guide_add) then + f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:) + else + f_add(ijb_v:ije_v,:)=(1.-tau)*vgui1(ijb_v:ije_v,:)+tau*vgui2(ijb_v:ije_v,:)-vcov(ijb_v:ije_v,:) + endif + + if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:)) + CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v) + IF (f_out) CALL guide_out("V",jjm,llm,f_add(1:ip1jm,:)/factt) + vcov(ijb_v:ije_v,:)=vcov(ijb_v:ije_v,:)+f_add(ijb_v:ije_v,:) + endif + + END SUBROUTINE guide_main + +!======================================================================= + SUBROUTINE guide_addfield(hsize,vsize,field,alpha) +! field1=a*field1+alpha*field2 + + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + + ! input variables + INTEGER, INTENT(IN) :: hsize + INTEGER, INTENT(IN) :: vsize + REAL, DIMENSION(hsize), INTENT(IN) :: alpha + REAL, DIMENSION(hsize,vsize), INTENT(INOUT) :: field + + ! Local variables + INTEGER :: l + + IF (hsize==ip1jm) THEN + do l=1,vsize + field(ijb_v:ije_v,l)=alpha(ijb_v:ije_v)*field(ijb_v:ije_v,l)*alpha_pcor(l) + enddo + ELSE + do l=1,vsize + field(ijb_u:ije_u,l)=alpha(ijb_u:ije_u)*field(ijb_u:ije_u,l)*alpha_pcor(l) + enddo + ENDIF + + END SUBROUTINE guide_addfield + +!======================================================================= + SUBROUTINE guide_zonave(typ,hsize,vsize,field) + + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "comgeom.h" + INCLUDE "comconst.h" + + ! input/output variables + INTEGER, INTENT(IN) :: typ + INTEGER, INTENT(IN) :: vsize + INTEGER, INTENT(IN) :: hsize + REAL, DIMENSION(hsize*iip1,vsize), INTENT(INOUT) :: field + + ! Local variables + LOGICAL, SAVE :: first=.TRUE. + INTEGER, DIMENSION (2), SAVE :: imin, imax ! averaging domain + INTEGER :: i,j,l,ij + REAL, DIMENSION (iip1) :: lond ! longitude in Deg. + REAL, DIMENSION (hsize,vsize):: fieldm ! zon-averaged field + + IF (first) THEN + first=.FALSE. +!Compute domain for averaging + lond=rlonu*180./pi + imin(1)=1;imax(1)=iip1; + imin(2)=1;imax(2)=iip1; + IF (guide_reg) THEN + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(1)=i + IF (lond(i).LE.lon_max_g) imax(1)=i + ENDDO + lond=rlonv*180./pi + DO i=1,iim + IF (lond(i).LT.lon_min_g) imin(2)=i + IF (lond(i).LE.lon_max_g) imax(2)=i + ENDDO + ENDIF + ENDIF + + fieldm=0. + + IF (hsize==jjm) THEN + DO l=1,vsize + ! Compute zonal average + DO j=jjb_v,jje_v + DO i=imin(typ),imax(typ) + ij=(j-1)*iip1+i + fieldm(j,l)=fieldm(j,l)+field(ij,l) + ENDDO + ENDDO + fieldm(:,l)=fieldm(:,l)/ REAL(imax(typ)-imin(typ)+1) + ! Compute forcing + DO j=jjb_v,jje_v + DO i=1,iip1 + ij=(j-1)*iip1+i + field(ij,l)=fieldm(j,l) + ENDDO + ENDDO + ENDDO + ELSE + DO l=1,vsize + ! Compute zonal average + DO j=jjb_v,jje_v + DO i=imin(typ),imax(typ) + ij=(j-1)*iip1+i + fieldm(j,l)=fieldm(j,l)+field(ij,l) + ENDDO + ENDDO + fieldm(:,l)=fieldm(:,l)/ REAL(imax(typ)-imin(typ)+1) + ! Compute forcing + DO j=jjb_u,jje_u + DO i=1,iip1 + ij=(j-1)*iip1+i + field(ij,l)=fieldm(j,l) + ENDDO + ENDDO + ENDDO + ENDIF + + END SUBROUTINE guide_zonave + +!======================================================================= + SUBROUTINE guide_interp(psi,teta) + USE parallel + USE mod_hallo + USE Bands + IMPLICIT NONE + + include "dimensions.h" + include "paramet.h" + include "comvert.h" + include "comgeom2.h" + include "comconst.h" + + REAL, DIMENSION (iip1,jjp1), INTENT(IN) :: psi ! Psol gcm + REAL, DIMENSION (iip1,jjp1,llm), INTENT(IN) :: teta ! Temp. Pot. gcm + + LOGICAL, SAVE :: first=.TRUE. + ! Variables pour niveaux pression: + REAL, DIMENSION (iip1,jjp1,nlevnc) :: plnc1,plnc2 !niveaux pression guidage + REAL, DIMENSION (iip1,jjp1,llm) :: plunc,plsnc !niveaux pression modele + REAL, DIMENSION (iip1,jjm,llm) :: plvnc !niveaux pression modele +!ym rustine temporaire pour ne pas depasser 2GB pour la stack +!ym => crach compilo avec la version intel 12 + REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE :: p ! pression intercouches + REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE :: pls, pext ! var intermediaire + REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE :: pbarx + REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE :: pbary + ! Variables pour fonction Exner (P milieu couche) + REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE :: pk, pkf + REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE :: alpha, beta + REAL, DIMENSION (:,:),ALLOCATABLE,SAVE :: pks + REAL :: prefkap,unskap + ! Pression de vapeur saturante + REAL, DIMENSION (ip1jmp1,llm) :: qsat + !Variables intermediaires interpolation + +!ym rustine temporaire pour ne pas depasser 2GB pour la stack +!ym => crach compilo avec la version intel 12 +! REAL, DIMENSION (iip1,jjp1,llm) :: zu1,zu2 +! REAL, DIMENSION (iip1,jjm,llm) :: zv1,zv2 + REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE :: zu1,zu2 + REAL, DIMENSION (:,:,:),ALLOCATABLE,SAVE :: zv1,zv2 + + INTEGER :: i,j,l,ij + TYPE(Request) :: Req + + print *,'Guide: conversion variables guidage' +! ----------------------------------------------------------------- +! Calcul des niveaux de pression champs guidage +! ----------------------------------------------------------------- +if (guide_modele) then + do i=1,iip1 + do j=jjb_u,jje_u + do l=1,nlevnc + plnc2(i,j,l)=apnc(l)+bpnc(l)*psnat2(i,j) + plnc1(i,j,l)=apnc(l)+bpnc(l)*psnat1(i,j) + enddo + enddo + enddo +else + do i=1,iip1 + do j=jjb_u,jje_u + do l=1,nlevnc + plnc2(i,j,l)=apnc(l) + plnc1(i,j,l)=apnc(l) + enddo + enddo + enddo + +endif + if (first) then + first=.FALSE. + print*,'Guide: verification ordre niveaux verticaux' + print*,'LMDZ :' + do l=1,llm + print*,'PL(',l,')=',(ap(l)+ap(l+1))/2. & + +psi(1,jje_u)*(bp(l)+bp(l+1))/2. + enddo + print*,'Fichiers guidage' + do l=1,nlevnc + print*,'PL(',l,')=',plnc2(1,jjb_u,l) + enddo + print *,'inversion de l''ordre: invert_p=',invert_p + if (guide_u) then + do l=1,nlevnc + print*,'U(',l,')=',unat2(1,jjb_u,l) + enddo + endif + if (guide_T) then + do l=1,nlevnc + print*,'T(',l,')=',tnat2(1,jjb_u,l) + enddo + endif + ALLOCATE( zu1(iip1,jjp1,llm),zu2(iip1,jjp1,llm)) + ALLOCATE( zv1(iip1,jjm,llm),zv2(iip1,jjm,llm)) + ALLOCATE( p(iip1,jjp1,llmp1) ) + ALLOCATE( pls(iip1,jjp1,llm), pext(iip1,jjp1,llm) ) + ALLOCATE( pbarx(iip1,jjp1,llm) ) + ALLOCATE( pbary(iip1,jjm,llm) ) + ALLOCATE( pk(iip1,jjp1,llm),pkf(iip1,jjp1,llm) ) + ALLOCATE( alpha(iip1,jjp1,llm),beta(iip1,jjp1,llm) ) + ALLOCATE( pks(iip1,jjp1) ) + endif + +! ----------------------------------------------------------------- +! Calcul niveaux pression modele +! ----------------------------------------------------------------- + CALL pression_p( ip1jmp1, ap, bp, psi, p ) + CALL exner_hyb_p(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf) + +! .... Calcul de pls , pression au milieu des couches ,en Pascals + unskap=1./kappa + prefkap = preff ** kappa + DO l = 1, llm + DO j=jjb_u,jje_u + DO i =1, iip1 + pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap + ENDDO + ENDDO + ENDDO + +! calcul des pressions pour les grilles u et v + do l=1,llm + do j=jjb_u,jje_u + do i=1,iip1 + pext(i,j,l)=pls(i,j,l)*aire(i,j) + enddo + enddo + enddo + + CALL Register_SwapFieldHallo(pext,pext,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req) + CALL SendRequest(Req) + CALL WaitRequest(Req) + + call massbar_p(pext, pbarx, pbary ) + do l=1,llm + do j=jjb_u,jje_u + do i=1,iip1 + plunc(i,j,l)=pbarx(i,j,l)/aireu(i,j) + plsnc(i,j,l)=pls(i,j,l) + enddo + enddo + enddo + do l=1,llm + do j=jjb_v,jje_v + do i=1,iip1 + plvnc(i,j,l)=pbary(i,j,l)/airev(i,j) + enddo + enddo + enddo + +! ----------------------------------------------------------------- +! Interpolation champs guidage sur niveaux modele (+inversion N/S) +! Conversion en variables gcm (ucov, vcov...) +! ----------------------------------------------------------------- + if (guide_P) then + do j=jjb_u,jje_u + do i=1,iim + ij=(j-1)*iip1+i + psgui1(ij)=psnat1(i,j) + psgui2(ij)=psnat2(i,j) + enddo + psgui1(iip1*j)=psnat1(1,j) + psgui2(iip1*j)=psnat2(1,j) + enddo + endif + + IF (guide_u) THEN + CALL pres2lev(unat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc1(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + CALL pres2lev(unat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc2(:,jjb_u:jje_u,:),plunc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + + do l=1,llm + do j=jjb_u,jje_u + do i=1,iim + ij=(j-1)*iip1+i + ugui1(ij,l)=zu1(i,j,l)*cu(i,j) + ugui2(ij,l)=zu2(i,j,l)*cu(i,j) + enddo + ugui1(j*iip1,l)=ugui1((j-1)*iip1+1,l) + ugui2(j*iip1,l)=ugui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + ugui1(i,l)=0. + ugui1(ip1jm+i,l)=0. + ugui2(i,l)=0. + ugui2(ip1jm+i,l)=0. + enddo + enddo + ENDIF + + IF (guide_T) THEN + CALL pres2lev(tnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + CALL pres2lev(tnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + + do l=1,llm + do j=jjb_u,jje_u + IF (guide_teta) THEN + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l) + tgui2(ij,l)=zu2(i,j,l) + enddo + ELSE + do i=1,iim + ij=(j-1)*iip1+i + tgui1(ij,l)=zu1(i,j,l)*cpp/pk(i,j,l) + tgui2(ij,l)=zu2(i,j,l)*cpp/pk(i,j,l) + enddo + ENDIF + tgui1(j*iip1,l)=tgui1((j-1)*iip1+1,l) + tgui2(j*iip1,l)=tgui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + tgui1(i,l)=tgui1(1,l) + tgui1(ip1jm+i,l)=tgui1(ip1jm+1,l) + tgui2(i,l)=tgui2(1,l) + tgui2(ip1jm+i,l)=tgui2(ip1jm+1,l) + enddo + enddo + ENDIF + + IF (guide_v) THEN + + CALL pres2lev(vnat1(:,jjb_v:jje_v,:),zv1(:,jjb_v:jje_v,:),nlevnc,llm, & + plnc1(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p) + CALL pres2lev(vnat2(:,jjb_v:jje_v,:),zv2(:,jjb_v:jje_v,:),nlevnc,llm, & + plnc2(:,jjb_v:jje_v,:),plvnc(:,jjb_v:jje_v,:),iip1,jjn_v,invert_p) + + do l=1,llm + do j=jjb_v,jje_v + do i=1,iim + ij=(j-1)*iip1+i + vgui1(ij,l)=zv1(i,j,l)*cv(i,j) + vgui2(ij,l)=zv2(i,j,l)*cv(i,j) + enddo + vgui1(j*iip1,l)=vgui1((j-1)*iip1+1,l) + vgui2(j*iip1,l)=vgui2((j-1)*iip1+1,l) + enddo + enddo + ENDIF + + IF (guide_Q) THEN + ! On suppose qu'on a la bonne variable dans le fichier de guidage: + ! Hum.Rel si guide_hr, Hum.Spec. sinon. + CALL pres2lev(qnat1(:,jjb_u:jje_u,:),zu1(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc1(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + CALL pres2lev(qnat2(:,jjb_u:jje_u,:),zu2(:,jjb_u:jje_u,:),nlevnc,llm, & + plnc2(:,jjb_u:jje_u,:),plsnc(:,jjb_u:jje_u,:),iip1,jjn_u,invert_p) + + do l=1,llm + do j=jjb_u,jjb_v + do i=1,iim + ij=(j-1)*iip1+i + qgui1(ij,l)=zu1(i,j,l) + qgui2(ij,l)=zu2(i,j,l) + enddo + qgui1(j*iip1,l)=qgui1((j-1)*iip1+1,l) + qgui2(j*iip1,l)=qgui2((j-1)*iip1+1,l) + enddo + do i=1,iip1 + qgui1(i,l)=qgui1(1,l) + qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) + qgui2(i,l)=qgui2(1,l) + qgui2(ip1jm+i,l)=qgui2(ip1jm+1,l) + enddo + enddo + IF (guide_hr) THEN + CALL q_sat(iip1*jjn_u*llm,teta(:,jjb_u:jje_u,:)*pk(:,jjb_u:jje_u,:)/cpp, & + plsnc(:,jjb_u:jje_u,:),qsat(ijb_u:ije_u,:)) + qgui1(ijb_u:ije_u,:)=qgui1(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 !hum. rel. en % + qgui2(ijb_u:ije_u,:)=qgui2(ijb_u:ije_u,:)*qsat(ijb_u:ije_u,:)*0.01 + ENDIF + ENDIF + + END SUBROUTINE guide_interp + +!======================================================================= + SUBROUTINE tau2alpha(typ,pim,pjm,factt,taumin,taumax,alpha) + +! Calcul des constantes de rappel alpha (=1/tau) + + implicit none + + include "dimensions.h" + include "paramet.h" + include "comconst.h" + include "comgeom2.h" + include "serre.h" + +! input arguments : + INTEGER, INTENT(IN) :: typ ! u(2),v(3), ou scalaire(1) + INTEGER, INTENT(IN) :: pim,pjm ! dimensions en lat, lon + REAL, INTENT(IN) :: factt ! pas de temps en fraction de jour + REAL, INTENT(IN) :: taumin,taumax +! output arguments: + REAL, DIMENSION(pim,pjm), INTENT(OUT) :: alpha + +! local variables: + LOGICAL, SAVE :: first=.TRUE. + REAL, SAVE :: gamma,dxdy_min,dxdy_max + REAL, DIMENSION (iip1,jjp1) :: zdx,zdy + REAL, DIMENSION (iip1,jjp1) :: dxdys,dxdyu + REAL, DIMENSION (iip1,jjm) :: dxdyv + real dxdy_ + real zlat,zlon + real alphamin,alphamax,xi + integer i,j,ilon,ilat + + + alphamin=factt/taumax + alphamax=factt/taumin + IF (guide_reg.OR.guide_add) THEN + alpha=alphamax +!----------------------------------------------------------------------- +! guide_reg: alpha=alpha_min dans region, 0. sinon. +!----------------------------------------------------------------------- + IF (guide_reg) THEN + do j=1,pjm + do i=1,pim + if (typ.eq.2) then + zlat=rlatu(j)*180./pi + zlon=rlonu(i)*180./pi + elseif (typ.eq.1) then + zlat=rlatu(j)*180./pi + zlon=rlonv(i)*180./pi + elseif (typ.eq.3) then + zlat=rlatv(j)*180./pi + zlon=rlonv(i)*180./pi + endif + alpha(i,j)=alphamax/16.* & + (1.+tanh((zlat-lat_min_g)/tau_lat))* & + (1.+tanh((lat_max_g-zlat)/tau_lat))* & + (1.+tanh((zlon-lon_min_g)/tau_lon))* & + (1.+tanh((lon_max_g-zlon)/tau_lon)) + enddo + enddo + ENDIF + ELSE +!----------------------------------------------------------------------- +! Sinon, alpha varie entre alpha_min et alpha_max suivant le zoom. +!----------------------------------------------------------------------- +!Calcul de l'aire des mailles + do j=2,jjm + do i=2,iip1 + zdx(i,j)=0.5*(cu(i-1,j)+cu(i,j))/cos(rlatu(j)) + enddo + zdx(1,j)=zdx(iip1,j) + enddo + do j=2,jjm + do i=1,iip1 + zdy(i,j)=0.5*(cv(i,j-1)+cv(i,j)) + enddo + enddo + do i=1,iip1 + zdx(i,1)=zdx(i,2) + zdx(i,jjp1)=zdx(i,jjm) + zdy(i,1)=zdy(i,2) + zdy(i,jjp1)=zdy(i,jjm) + enddo + do j=1,jjp1 + do i=1,iip1 + dxdys(i,j)=sqrt(zdx(i,j)*zdx(i,j)+zdy(i,j)*zdy(i,j)) + enddo + enddo + IF (typ.EQ.2) THEN + do j=1,jjp1 + do i=1,iim + dxdyu(i,j)=0.5*(dxdys(i,j)+dxdys(i+1,j)) + enddo + dxdyu(iip1,j)=dxdyu(1,j) + enddo + ENDIF + IF (typ.EQ.3) THEN + do j=1,jjm + do i=1,iip1 + dxdyv(i,j)=0.5*(dxdys(i,j)+dxdys(i,j+1)) + enddo + enddo + ENDIF +! Premier appel: calcul des aires min et max et de gamma. + IF (first) THEN + first=.FALSE. + ! coordonnees du centre du zoom + CALL coordij(clon,clat,ilon,ilat) + ! aire de la maille au centre du zoom + dxdy_min=dxdys(ilon,ilat) + ! dxdy maximale de la maille + dxdy_max=0. + do j=1,jjp1 + do i=1,iip1 + dxdy_max=max(dxdy_max,dxdys(i,j)) + enddo + enddo + ! Calcul de gamma + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + print*,'ATTENTION modele peu zoome' + print*,'ATTENTION on prend une constante de guidage cste' + gamma=0. + else + gamma=(dxdy_max-2.*dxdy_min)/(dxdy_max-dxdy_min) + print*,'gamma=',gamma + if (gamma.lt.1.e-5) then + print*,'gamma =',gamma,'<1e-5' + stop + endif + gamma=log(0.5)/log(gamma) + if (gamma4) then + gamma=min(gamma,4.) + endif + print*,'gamma=',gamma + endif + ENDIF !first + + do j=1,pjm + do i=1,pim + if (typ.eq.1) then + dxdy_=dxdys(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.2) then + dxdy_=dxdyu(i,j) + zlat=rlatu(j)*180./pi + elseif (typ.eq.3) then + dxdy_=dxdyv(i,j) + zlat=rlatv(j)*180./pi + endif + if (abs(grossismx-1.).lt.0.1.or.abs(grossismy-1.).lt.0.1) then + ! pour une grille reguliere, xi=xxx**0=1 -> alpha=alphamin + alpha(i,j)=alphamin + else + xi=((dxdy_max-dxdy_)/(dxdy_max-dxdy_min))**gamma + xi=min(xi,1.) + if(lat_min_g.le.zlat .and. zlat.le.lat_max_g) then + alpha(i,j)=xi*alphamin+(1.-xi)*alphamax + else + alpha(i,j)=0. + endif + endif + enddo + enddo + ENDIF ! guide_reg + + END SUBROUTINE tau2alpha + +!======================================================================= + SUBROUTINE guide_read(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidQ + INTEGER, SAVE :: varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Niveaux de pression si non constants + if (guide_modele) then + print *,'Lecture du guidage sur niveaux mod�le' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (.not.guide_modele) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + if (guide_modele) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + else +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + endif + first=.FALSE. + endif ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=timestep + + count(1)=iip1 + count(2)=jjp1 + count(3)=nlevnc + count(4)=1 + +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,unat2) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,unat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,unat2) + ENDIF + + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,tnat2) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,tnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,tnat2) + ENDIF + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,qnat2) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,qnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,qnat2) + ENDIF + + endif + +! Vent meridien + if (guide_v) then + count(2)=jjm +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,vnat2) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,vnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjm,llm,vnat2) + ENDIF + endif + +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + start(3)=timestep + start(4)=0 + count(2)=jjp1 + count(3)=1 + count(4)=0 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,psnat2) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,psnat2) +#endif + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,1,psnat2) + ENDIF + endif + + END SUBROUTINE guide_read + +!======================================================================= + SUBROUTINE guide_read2D(timestep) + + IMPLICIT NONE + +#include "netcdf.inc" +#include "dimensions.h" +#include "paramet.h" + + INTEGER, INTENT(IN) :: timestep + + LOGICAL, SAVE :: first=.TRUE. +! Identification fichiers et variables NetCDF: + INTEGER, SAVE :: ncidu,varidu,ncidv,varidv,ncidQ + INTEGER, SAVE :: varidQ,ncidt,varidt,ncidps,varidps + INTEGER :: ncidpl,varidpl,varidap,varidbp +! Variables auxiliaires NetCDF: + INTEGER, DIMENSION(4) :: start,count + INTEGER :: status,rcode +! Variables for 3D extension: + REAL, DIMENSION (jjp1,llm) :: zu + REAL, DIMENSION (jjm,llm) :: zv + INTEGER :: i + +! ----------------------------------------------------------------- +! Premier appel: initialisation de la lecture des fichiers +! ----------------------------------------------------------------- + if (first) then + ncidpl=-99 + print*,'Guide: ouverture des fichiers guidage ' +! Niveaux de pression si non constants + if (guide_modele) then + print *,'Lecture du guidage sur niveaux mod�le' + rcode = nf90_open('apbp.nc', nf90_nowrite, ncidpl) + rcode = nf90_inq_varid(ncidpl, 'AP', varidap) + rcode = nf90_inq_varid(ncidpl, 'BP', varidbp) + print*,'ncidpl,varidap',ncidpl,varidap + endif +! Vent zonal + if (guide_u) then + rcode = nf90_open('u.nc', nf90_nowrite, ncidu) + rcode = nf90_inq_varid(ncidu, 'UWND', varidu) + print*,'ncidu,varidu',ncidu,varidu + if (ncidpl.eq.-99) ncidpl=ncidu + endif +! Vent meridien + if (guide_v) then + rcode = nf90_open('v.nc', nf90_nowrite, ncidv) + rcode = nf90_inq_varid(ncidv, 'VWND', varidv) + print*,'ncidv,varidv',ncidv,varidv + if (ncidpl.eq.-99) ncidpl=ncidv + endif +! Temperature + if (guide_T) then + rcode = nf90_open('T.nc', nf90_nowrite, ncidt) + rcode = nf90_inq_varid(ncidt, 'AIR', varidt) + print*,'ncidT,varidT',ncidt,varidt + if (ncidpl.eq.-99) ncidpl=ncidt + endif +! Humidite + if (guide_Q) then + rcode = nf90_open('hur.nc', nf90_nowrite, ncidQ) + rcode = nf90_inq_varid(ncidQ, 'RH', varidQ) + print*,'ncidQ,varidQ',ncidQ,varidQ + if (ncidpl.eq.-99) ncidpl=ncidQ + endif +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + rcode = nf90_open('ps.nc', nf90_nowrite, ncidps) + rcode = nf90_inq_varid(ncidps, 'SP', varidps) + print*,'ncidps,varidps',ncidps,varidps + endif +! Coordonnee verticale + if (.not.guide_modele) then + rcode = nf90_inq_varid(ncidpl, 'LEVEL', varidpl) + IF (rcode.NE.0) rcode = nf90_inq_varid(ncidpl, 'PRESSURE', varidpl) + print*,'ncidpl,varidpl',ncidpl,varidpl + endif +! Coefs ap, bp pour calcul de la pression aux differents niveaux + if (guide_modele) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_DOUBLE(ncidpl,varidbp,1,nlevnc,bpnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidap,1,nlevnc,apnc) + status=NF_GET_VARA_REAL(ncidpl,varidbp,1,nlevnc,bpnc) +#endif + else +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidpl,varidpl,1,nlevnc,apnc) +#else + status=NF_GET_VARA_REAL(ncidpl,varidpl,1,nlevnc,apnc) +#endif + apnc=apnc*100.! conversion en Pascals + bpnc(:)=0. + endif + first=.FALSE. + endif ! (first) + +! ----------------------------------------------------------------- +! lecture des champs u, v, T, Q, ps +! ----------------------------------------------------------------- + +! dimensions pour les champs scalaires et le vent zonal + start(1)=1 + start(2)=1 + start(3)=1 + start(4)=timestep + + count(1)=1 + count(2)=jjp1 + count(3)=nlevnc + count(4)=1 + +! Vent zonal + if (guide_u) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidu,varidu,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidu,varidu,start,count,zu) +#endif + DO i=1,iip1 + unat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,unat2) + ENDIF + + endif + +! Temperature + if (guide_T) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidt,varidt,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidt,varidt,start,count,zu) +#endif + DO i=1,iip1 + tnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,tnat2) + ENDIF + + endif + +! Humidite + if (guide_Q) then +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidQ,varidQ,start,count,zu) +#else + status=NF_GET_VARA_REAL(ncidQ,varidQ,start,count,zu) +#endif + DO i=1,iip1 + qnat2(i,:,:)=zu(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,llm,qnat2) + ENDIF + + endif + +! Vent meridien + if (guide_v) then + count(2)=jjm +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidv,varidv,start,count,zv) +#else + status=NF_GET_VARA_REAL(ncidv,varidv,start,count,zv) +#endif + DO i=1,iip1 + vnat2(i,:,:)=zv(:,:) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjm,llm,vnat2) + ENDIF + + endif + +! Pression de surface + if ((guide_P).OR.(guide_modele)) then + start(3)=timestep + start(4)=0 + count(2)=jjp1 + count(3)=1 + count(4)=0 +#ifdef NC_DOUBLE + status=NF_GET_VARA_DOUBLE(ncidps,varidps,start,count,zu(:,1)) +#else + status=NF_GET_VARA_REAL(ncidps,varidps,start,count,zu(:,1)) +#endif + DO i=1,iip1 + psnat2(i,:)=zu(:,1) + ENDDO + + IF (invert_y) THEN + CALL invert_lat(iip1,jjp1,1,psnat2) + ENDIF + + endif + + END SUBROUTINE guide_read2D + +!======================================================================= + SUBROUTINE guide_out(varname,hsize,vsize,field) + USE parallel + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + INCLUDE "netcdf.inc" + INCLUDE "comgeom2.h" + INCLUDE "comconst.h" + INCLUDE "comvert.h" + + ! Variables entree + CHARACTER, INTENT(IN) :: varname + INTEGER, INTENT (IN) :: hsize,vsize + REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field + + ! Variables locales + INTEGER, SAVE :: timestep=0 + ! Identites fichier netcdf + INTEGER :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev + INTEGER :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev + INTEGER, DIMENSION (3) :: dim3 + INTEGER, DIMENSION (4) :: dim4,count,start + INTEGER :: ierr, varid + + CALL gather_field(field,iip1*hsize,vsize,0) + + IF (mpi_rank /= 0) RETURN + + print *,'Guide: output timestep',timestep,'var ',varname + IF (timestep.EQ.0) THEN +! ---------------------------------------------- +! initialisation fichier de sortie +! ---------------------------------------------- +! Ouverture du fichier + ierr=NF_CREATE("guide_ins.nc",NF_CLOBBER,nid) +! Definition des dimensions + ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) + ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) + ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) + ierr=NF_DEF_DIM(nid,"LATV",jjm,id_latv) + ierr=NF_DEF_DIM(nid,"LEVEL",llm,id_lev) + ierr=NF_DEF_DIM(nid,"TIME",NF_UNLIMITED,id_tim) + +! Creation des variables dimensions + ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu) + ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv) + ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu) + ierr=NF_DEF_VAR(nid,"LATV",NF_FLOAT,1,id_latv,vid_latv) + ierr=NF_DEF_VAR(nid,"LEVEL",NF_FLOAT,1,id_lev,vid_lev) + ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu) + ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv) + + ierr=NF_ENDDEF(nid) + +! Enregistrement des variables dimensions +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu) + ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv) +#else + ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latu,rlatu*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_latv,rlatv*180./pi) + ierr = NF_PUT_VAR_REAL(nid,vid_lev,presnivs) + ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu) + ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv) +#endif +! -------------------------------------------------------------------- +! Cr�ation des variables sauvegard�es +! -------------------------------------------------------------------- + ierr = NF_REDEF(nid) +! Surface pressure (GCM) + dim3=(/id_lonv,id_latu,id_tim/) + ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,3,dim3,varid) +! Surface pressure (guidage) + IF (guide_P) THEN + dim3=(/id_lonv,id_latu,id_tim/) + ierr = NF_DEF_VAR(nid,"ps",NF_FLOAT,3,dim3,varid) + ENDIF +! Zonal wind + IF (guide_u) THEN + dim4=(/id_lonu,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid) + ENDIF +! Merid. wind + IF (guide_v) THEN + dim4=(/id_lonv,id_latv,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid) + ENDIF +! Pot. Temperature + IF (guide_T) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"teta",NF_FLOAT,4,dim4,varid) + ENDIF +! Specific Humidity + IF (guide_Q) THEN + dim4=(/id_lonv,id_latu,id_lev,id_tim/) + ierr = NF_DEF_VAR(nid,"q",NF_FLOAT,4,dim4,varid) + ENDIF + + ierr = NF_ENDDEF(nid) + ierr = NF_CLOSE(nid) + ENDIF ! timestep=0 + +! -------------------------------------------------------------------- +! Enregistrement du champ +! -------------------------------------------------------------------- + ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid) + + SELECT CASE (varname) + CASE ("S") + timestep=timestep+1 + ierr = NF_INQ_VARID(nid,"SP",varid) + start=(/1,1,timestep,0/) + count=(/iip1,jjp1,1,0/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("P") + ierr = NF_INQ_VARID(nid,"ps",varid) + start=(/1,1,timestep,0/) + count=(/iip1,jjp1,1,0/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("U") + ierr = NF_INQ_VARID(nid,"ucov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("V") + ierr = NF_INQ_VARID(nid,"vcov",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjm,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("T") + ierr = NF_INQ_VARID(nid,"teta",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + CASE ("Q") + ierr = NF_INQ_VARID(nid,"q",varid) + start=(/1,1,1,timestep/) + count=(/iip1,jjp1,llm,1/) +#ifdef NC_DOUBLE + ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) +#else + ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) +#endif + END SELECT + + ierr = NF_CLOSE(nid) + + END SUBROUTINE guide_out + + +!=========================================================================== + subroutine correctbid(iim,nl,x) + integer iim,nl + real x(iim+1,nl) + integer i,l + real zz + + do l=1,nl + do i=2,iim-1 + if(abs(x(i,l)).gt.1.e10) then + zz=0.5*(x(i-1,l)+x(i+1,l)) + print*,'correction ',i,l,x(i,l),zz + x(i,l)=zz + endif + enddo + enddo + return + end subroutine correctbid + +!=========================================================================== +END MODULE guide_p_mod Index: /LMDZ5/trunk/libf/dyn3dmem/heavyside.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/heavyside.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/heavyside.F (revision 1632) @@ -0,0 +1,23 @@ +! +! $Header$ +! +c +c + FUNCTION heavyside(a) + +c ... P. Le Van .... +c + IMPLICIT NONE + + REAL(KIND=8) heavyside , a + + IF ( a.LE.0. ) THEN + heavyside = 0. + ELSE + heavyside = 1. + ENDIF + + RETURN + END + + Index: /LMDZ5/trunk/libf/dyn3dmem/infotrac.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/infotrac.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/infotrac.F90 (revision 1632) @@ -0,0 +1,335 @@ +! $Id$ +! +MODULE infotrac + +! nqtot : total number of tracers and higher order of moment, water vapor and liquid included + INTEGER, SAVE :: nqtot + +! nbtr : number of tracers not including higher order of moment or water vapor or liquid +! number of tracers used in the physics + INTEGER, SAVE :: nbtr + +! Name variables + CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics + CHARACTER(len=23), ALLOCATABLE, DIMENSION(:), SAVE :: ttext ! tracer long name for diagnostics + +! iadv : index of trasport schema for each tracer + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: iadv + +! niadv : vector keeping the coorspondance between all tracers(nqtot) treated in the +! dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code. + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: niadv ! equivalent dyn / physique + +! conv_flg(it)=0 : convection desactivated for tracer number it + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: conv_flg +! pbl_flg(it)=0 : boundary layer diffusion desactivaded for tracer number it + INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: pbl_flg + + CHARACTER(len=4),SAVE :: type_trac + +CONTAINS + + SUBROUTINE infotrac_init + USE control_mod + IMPLICIT NONE +!======================================================================= +! +! Auteur: P. Le Van /L. Fairhead/F.Hourdin +! ------- +! Modif special traceur F.Forget 05/94 +! Modif M-A Filiberti 02/02 lecture de traceur.def +! +! Objet: +! ------ +! GCM LMD nouvelle grille +! +!======================================================================= +! ... modification de l'integration de q ( 26/04/94 ) .... +!----------------------------------------------------------------------- +! Declarations + + INCLUDE "dimensions.h" + INCLUDE "iniprint.h" + +! Local variables + INTEGER, ALLOCATABLE, DIMENSION(:) :: hadv ! index of horizontal trasport schema + INTEGER, ALLOCATABLE, DIMENSION(:) :: vadv ! index of vertical trasport schema + + CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0 ! tracer short name + CHARACTER(len=8), ALLOCATABLE, DIMENSION(:) :: tracnam ! name from INCA + CHARACTER(len=3), DIMENSION(30) :: descrq + CHARACTER(len=1), DIMENSION(3) :: txts + CHARACTER(len=2), DIMENSION(9) :: txtp + CHARACTER(len=13) :: str1,str2 + + INTEGER :: nqtrue ! number of tracers read from tracer.def, without higer order of moment + INTEGER :: iq, new_iq, iiq, jq, ierr + INTEGER, EXTERNAL :: lnblnk + +!----------------------------------------------------------------------- +! Initialization : +! + txts=(/'x','y','z'/) + txtp=(/'x ','y ','z ','xx','xy','xz','yy','yz','zz'/) + + descrq(14)='VLH' + descrq(10)='VL1' + descrq(11)='VLP' + descrq(12)='FH1' + descrq(13)='FH2' + descrq(16)='PPM' + descrq(17)='PPS' + descrq(18)='PPP' + descrq(20)='SLP' + descrq(30)='PRA' + + + IF (config_inca=='none') THEN + type_trac='lmdz' + ELSE + type_trac='inca' + END IF + +!----------------------------------------------------------------------- +! +! 1) Get the true number of tracers + water vapor/liquid +! Here true tracers (nqtrue) means declared tracers (only first order) +! +!----------------------------------------------------------------------- + IF (type_trac == 'lmdz') THEN + OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr) + IF(ierr.EQ.0) THEN + WRITE(lunout,*) 'Open traceur.def : ok' + READ(90,*) nqtrue + ELSE + WRITE(lunout,*) 'Problem in opening traceur.def' + WRITE(lunout,*) 'ATTENTION using defaut values' + nqtrue=4 ! Defaut value + END IF + ! Attention! Only for planet_type=='earth' + nbtr=nqtrue-2 + ELSE + ! nbtr has been read from INCA by init_cont_lmdz() in gcm.F + nqtrue=nbtr+2 + END IF + + IF (nqtrue < 2) THEN + WRITE(lunout,*) 'nqtrue=',nqtrue, ' is not allowded. 2 tracers is the minimum' + CALL abort_gcm('infotrac_init','Not enough tracers',1) + END IF +! +! Allocate variables depending on nqtrue and nbtr +! + ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue)) + ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), tracnam(nbtr)) + conv_flg(:) = 1 ! convection activated for all tracers + pbl_flg(:) = 1 ! boundary layer activated for all tracers + +!----------------------------------------------------------------------- +! 2) Choix des schemas d'advection pour l'eau et les traceurs +! +! iadv = 1 schema transport type "humidite specifique LMD" +! iadv = 2 schema amont +! iadv = 14 schema Van-leer + humidite specifique +! Modif F.Codron +! iadv = 10 schema Van-leer (retenu pour l'eau vapeur et liquide) +! iadv = 11 schema Van-Leer pour hadv et version PPM (Monotone) pour vadv +! iadv = 12 schema Frederic Hourdin I +! iadv = 13 schema Frederic Hourdin II +! iadv = 16 schema PPM Monotone(Collela & Woodward 1984) +! iadv = 17 schema PPM Semi Monotone (overshoots autorisés) +! iadv = 18 schema PPM Positif Defini (overshoots undershoots autorisés) +! iadv = 20 schema Slopes +! iadv = 30 schema Prather +! +! Dans le tableau q(ij,l,iq) : iq = 1 pour l'eau vapeur +! iq = 2 pour l'eau liquide +! Et eventuellement iq = 3,nqtot pour les autres traceurs +! +! iadv(1): choix pour l'eau vap. et iadv(2) : choix pour l'eau liq. +!------------------------------------------------------------------------ +! +! Get choice of advection schema from file tracer.def or from INCA +!--------------------------------------------------------------------- + IF (type_trac == 'lmdz') THEN + IF(ierr.EQ.0) THEN + ! Continue to read tracer.def + DO iq=1,nqtrue + READ(90,999) hadv(iq),vadv(iq),tnom_0(iq) + END DO + CLOSE(90) + ELSE ! Without tracer.def + hadv(1) = 14 + vadv(1) = 14 + tnom_0(1) = 'H2Ov' + hadv(2) = 10 + vadv(2) = 10 + tnom_0(2) = 'H2Ol' + hadv(3) = 10 + vadv(3) = 10 + tnom_0(3) = 'RN' + hadv(4) = 10 + vadv(4) = 10 + tnom_0(4) = 'PB' + END IF + + WRITE(lunout,*) 'Valeur de traceur.def :' + WRITE(lunout,*) 'nombre de traceurs ',nqtrue + DO iq=1,nqtrue + WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq) + END DO + + ELSE ! type_trac=inca : config_inca='aero' ou 'chem' +! le module de chimie fournit les noms des traceurs +! et les schemas d'advection associes. + +#ifdef INCA + CALL init_transport( & + hadv, & + vadv, & + conv_flg, & + pbl_flg, & + tracnam) +#endif + tnom_0(1)='H2Ov' + tnom_0(2)='H2Ol' + + DO iq =3,nqtrue + tnom_0(iq)=tracnam(iq-2) + END DO + + END IF ! type_trac + +!----------------------------------------------------------------------- +! +! 3) Verify if advection schema 20 or 30 choosen +! Calculate total number of tracers needed: nqtot +! Allocate variables depending on total number of tracers +!----------------------------------------------------------------------- + new_iq=0 + DO iq=1,nqtrue + ! Add tracers for certain advection schema + IF (hadv(iq)<20 .AND. vadv(iq)<20 ) THEN + new_iq=new_iq+1 ! no tracers added + ELSE IF (hadv(iq)==20 .AND. vadv(iq)==20 ) THEN + new_iq=new_iq+4 ! 3 tracers added + ELSE IF (hadv(iq)==30 .AND. vadv(iq)==30 ) THEN + new_iq=new_iq+10 ! 9 tracers added + ELSE + WRITE(lunout,*) 'This choice of advection schema is not available' + CALL abort_gcm('infotrac_init','Bad choice of advection schema - 1',1) + END IF + END DO + + IF (new_iq /= nqtrue) THEN + ! The choice of advection schema imposes more tracers + ! Assigne total number of tracers + nqtot = new_iq + + WRITE(lunout,*) 'The choice of advection schema for one or more tracers' + WRITE(lunout,*) 'makes it necessary to add tracers' + WRITE(lunout,*) nqtrue,' is the number of true tracers' + WRITE(lunout,*) nqtot, ' is the total number of tracers needed' + + ELSE + ! The true number of tracers is also the total number + nqtot = nqtrue + END IF + +! +! Allocate variables with total number of tracers, nqtot +! + ALLOCATE(tname(nqtot), ttext(nqtot)) + ALLOCATE(iadv(nqtot), niadv(nqtot)) + +!----------------------------------------------------------------------- +! +! 4) Determine iadv, long and short name +! +!----------------------------------------------------------------------- + new_iq=0 + DO iq=1,nqtrue + new_iq=new_iq+1 + + ! Verify choice of advection schema + IF (hadv(iq)==vadv(iq)) THEN + iadv(new_iq)=hadv(iq) + ELSE IF (hadv(iq)==10 .AND. vadv(iq)==16) THEN + iadv(new_iq)=11 + ELSE + WRITE(lunout,*)'This choice of advection schema is not available' + CALL abort_gcm('infotrac_init','Bad choice of advection schema - 2',1) + END IF + + str1=tnom_0(iq) + tname(new_iq)= tnom_0(iq) + IF (iadv(new_iq)==0) THEN + ttext(new_iq)=str1(1:lnblnk(str1)) + ELSE + ttext(new_iq)=str1(1:lnblnk(str1))//descrq(iadv(new_iq)) + END IF + + ! schemas tenant compte des moments d'ordre superieur + str2=ttext(new_iq) + IF (iadv(new_iq)==20) THEN + DO jq=1,3 + new_iq=new_iq+1 + iadv(new_iq)=-20 + ttext(new_iq)=str2(1:lnblnk(str2))//txts(jq) + tname(new_iq)=str1(1:lnblnk(str1))//txts(jq) + END DO + ELSE IF (iadv(new_iq)==30) THEN + DO jq=1,9 + new_iq=new_iq+1 + iadv(new_iq)=-30 + ttext(new_iq)=str2(1:lnblnk(str2))//txtp(jq) + tname(new_iq)=str1(1:lnblnk(str1))//txtp(jq) + END DO + END IF + END DO + +! +! Find vector keeping the correspodence between true and total tracers +! + niadv(:)=0 + iiq=0 + DO iq=1,nqtot + IF(iadv(iq).GE.0) THEN + ! True tracer + iiq=iiq+1 + niadv(iiq)=iq + ENDIF + END DO + + + WRITE(lunout,*) 'Information stored in infotrac :' + WRITE(lunout,*) 'iadv niadv tname ttext :' + DO iq=1,nqtot + WRITE(lunout,*) iadv(iq),niadv(iq), tname(iq), ttext(iq) + END DO + +! +! Test for advection schema. +! This version of LMDZ only garantees iadv=10 and iadv=14 (14 only for water vapour) . +! + DO iq=1,nqtot + IF (iadv(iq)/=10 .AND. iadv(iq)/=14 .AND. iadv(iq)/=0) THEN + WRITE(lunout,*)'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' + CALL abort_gcm('infotrac_init','In this version only iadv=10 and iadv=14 is tested!',1) + ELSE IF (iadv(iq)==14 .AND. iq/=1) THEN + WRITE(lunout,*)'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ' + CALL abort_gcm('infotrac_init','In this version iadv=14 is only permitted for water vapour!',1) + END IF + END DO + +!----------------------------------------------------------------------- +! Finalize : +! + DEALLOCATE(tnom_0, hadv, vadv) + DEALLOCATE(tracnam) + +999 FORMAT (i2,1x,i2,1x,a15) + + END SUBROUTINE infotrac_init + +END MODULE infotrac Index: /LMDZ5/trunk/libf/dyn3dmem/iniacademic.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/iniacademic.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/iniacademic.F (revision 1632) @@ -0,0 +1,201 @@ +! +! $Id: iniacademic.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c +c + SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) + + USE filtreg_mod + USE infotrac, ONLY : nqtot + +c%W% %G% +c======================================================================= +c +c Author: Frederic Hourdin original: 15/01/93 +c ------- +c +c Subject: +c ------ +c +c Method: +c -------- +c +c Interface: +c ---------- +c +c Input: +c ------ +c +c Output: +c ------- +c +c======================================================================= + USE control_mod + IMPLICIT NONE +c----------------------------------------------------------------------- +c Declararations: +c --------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +#include "academic.h" +#include "ener.h" +#include "temps.h" +#include "iniprint.h" + +c Arguments: +c ---------- + + real time_0 + +c variables dynamiques + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) ! vents covariants + REAL teta(ip1jmp1,llm) ! temperature potentielle + REAL q(ip1jmp1,llm,nqtot) ! champs advectes + REAL ps(ip1jmp1) ! pression au sol + REAL masse(ip1jmp1,llm) ! masse d'air + REAL phis(ip1jmp1) ! geopotentiel au sol + +c Local: +c ------ + + REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches + REAL pks(ip1jmp1) ! exner au sol + REAL pk(ip1jmp1,llm) ! exner au milieu des couches + REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches + REAL phi(ip1jmp1,llm) ! geopotentiel + REAL ddsin,tetarappelj,tetarappell,zsig + real tetajl(jjp1,llm) + INTEGER i,j,l,lsup,ij + + real zz,ran1 + integer idum + + REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr + +c----------------------------------------------------------------------- +! 1. Initializations for Earth-like case +! -------------------------------------- + if (planet_type=="earth") then +c + time_0=0. + day_ref=0 + annee_ref=0 + + im = iim + jm = jjm + day_ini = 0 + omeg = 4.*asin(1.)/86400. + rad = 6371229. + g = 9.8 + daysec = 86400. + dtvr = daysec/REAL(day_step) + zdtvr=dtvr + kappa = 0.2857143 + cpp = 1004.70885 + preff = 101325. + pa = 50000. + etot0 = 0. + ptot0 = 0. + ztot0 = 0. + stot0 = 0. + ang0 = 0. + + CALL iniconst + CALL inigeom + CALL inifilr + + ps=0. + phis=0. +c--------------------------------------------------------------------- + + taurappel=10.*daysec + +c--------------------------------------------------------------------- +c Calcul de la temperature potentielle : +c -------------------------------------- + + DO l=1,llm + zsig=ap(l)/preff+bp(l) + if (zsig.gt.0.3) then + lsup=l + tetarappell=1./8.*(-log(zsig)-.5) + DO j=1,jjp1 + ddsin=sin(rlatu(j))-sin(pi/20.) + tetajl(j,l)=300.*(1+1./18.*(1.-3.*ddsin*ddsin)+tetarappell) + ENDDO + else +c Choix isotherme au-dessus de 300 mbar + do j=1,jjp1 + tetajl(j,l)=tetajl(j,lsup)*(0.3/zsig)**kappa + enddo + endif ! of if (zsig.gt.0.3) + ENDDO ! of DO l=1,llm + + do l=1,llm + do j=1,jjp1 + do i=1,iip1 + ij=(j-1)*iip1+i + tetarappel(ij,l)=tetajl(j,l) + enddo + enddo + enddo + +c call dump2d(jjp1,llm,tetajl,'TEQ ') + + ps=1.e5 + phis=0. + CALL pression ( ip1jmp1, ap, bp, ps, p ) + CALL exner_hyb( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) + CALL massdair(p,masse) + +c intialisation du vent et de la temperature + teta(:,:)=tetarappel(:,:) + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + call ugeostr(phi,ucov) + vcov=0. + q(:,:,1 )=1.e-10 + q(:,:,2 )=1.e-15 + q(:,:,3:nqtot)=0. + + +c perturbation aleatoire sur la temperature + idum = -1 + zz = ran1(idum) + idum = 0 + do l=1,llm + do ij=iip2,ip1jm + teta(ij,l)=teta(ij,l)*(1.+0.005*ran1(idum)) + enddo + enddo + + do l=1,llm + do ij=1,ip1jmp1,iip1 + teta(ij+iim,l)=teta(ij,l) + enddo + enddo + + + +c PRINT *,' Appel test_period avec tetarappel ' +c CALL test_period ( ucov,vcov,tetarappel,q,p,phis ) +c PRINT *,' Appel test_period avec teta ' +c CALL test_period ( ucov,vcov,teta,q,p,phis ) + +c initialisation d'un traceur sur une colonne + j=jjp1*3/4 + i=iip1/2 + ij=(j-1)*iip1+i + q(ij,:,3)=1. + + else + write(lunout,*)"iniacademic: planet types other than earth", + & " not implemented (yet)." + stop + endif ! of if (planet_type=="earth") + return + END +c----------------------------------------------------------------------- Index: /LMDZ5/trunk/libf/dyn3dmem/iniconst.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/iniconst.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/iniconst.F (revision 1632) @@ -0,0 +1,63 @@ +! +! $Id: iniconst.F 1299 2010-01-20 14:27:21Z fairhead $ +! + SUBROUTINE iniconst + + USE control_mod + IMPLICIT NONE +c +c P. Le Van +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "temps.h" +#include "comvert.h" + + +c +c +c +c----------------------------------------------------------------------- +c dimension des boucles: +c ---------------------- + + im = iim + jm = jjm + lllm = llm + imp1 = iim + jmp1 = jjm + 1 + lllmm1 = llm - 1 + lllmp1 = llm + 1 + + if (planet_type=="earth") then + disvert_type=1 + else + disvert_type=2 + endif + +c----------------------------------------------------------------------- + + dtdiss = idissip * dtvr + dtphys = iphysiq * dtvr + unsim = 1./iim + pi = 2.*ASIN( 1. ) + +c----------------------------------------------------------------------- +c + + r = cpp * kappa + + PRINT*,' R CP Kappa ', r , cpp, kappa +c +c----------------------------------------------------------------------- + + CALL disvert(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig) +c +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/inidissip.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/inidissip.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/inidissip.F (revision 1632) @@ -0,0 +1,226 @@ +! +! $Id: inidissip.F 1299 2010-01-20 14:27:21Z fairhead $ +! + SUBROUTINE inidissip ( lstardis,nitergdiv,nitergrot,niterh , + * tetagdiv,tetagrot,tetatemp ) +c======================================================================= +c initialisation de la dissipation horizontale +c======================================================================= +c----------------------------------------------------------------------- +c declarations: +c ------------- + + USE control_mod + + IMPLICIT NONE +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "comconst.h" +#include "comvert.h" +#include "logic.h" + + LOGICAL lstardis + INTEGER nitergdiv,nitergrot,niterh + REAL tetagdiv,tetagrot,tetatemp + REAL fact,zvert(llm),zz + REAL zh(ip1jmp1),zu(ip1jmp1),zv(ip1jm),deltap(ip1jmp1,llm) + REAL ullm,vllm,umin,vmin,zhmin,zhmax + REAL zllm,z1llm + + INTEGER l,ij,idum,ii + REAL tetamin + REAL pseudoz + + REAL ran1 + + +c----------------------------------------------------------------------- +c +c calcul des valeurs propres des operateurs par methode iterrative: +c ----------------------------------------------------------------- + + crot = -1. + cdivu = -1. + cdivh = -1. + +c calcul de la valeur propre de divgrad: +c -------------------------------------- + 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 + PRINT*,' Inidissip zh min max ',zhmin,zhmax + STOP'probleme generateur alleatoire dans inidissip' + ENDIF + + zllm = ABS( zhmax ) + DO l = 1,50 + IF(lstardis) THEN + CALL divgrad2(1,zh,deltap,niterh,zh) + ELSE + CALL divgrad (1,zh,niterh,zh) + ENDIF + + CALL minmax(iip1*jjp1,zh,zhmin,zhmax ) + + zllm = ABS( zhmax ) + z1llm = 1./zllm + DO ij = 1,ip1jmp1 + zh(ij) = zh(ij)* z1llm + ENDDO + ENDDO + + IF(lstardis) THEN + cdivh = 1./ zllm + ELSE + cdivh = zllm ** ( -1./niterh ) + ENDIF + +c calcul des valeurs propres de gradiv (ii =1) et nxgrarot(ii=2) +c ----------------------------------------------------------------- + print*,'calcul des valeurs propres' + + DO 20 ii = 1, 2 +c + 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 5 l = 1, 50 + IF(ii.EQ.1) THEN +ccccc CALL covcont( 1,zu,zv,zu,zv ) + IF(lstardis) THEN + CALL gradiv2( 1,zu,zv,nitergdiv,zu,zv ) + ELSE + CALL gradiv ( 1,zu,zv,nitergdiv,zu,zv ) + ENDIF + ELSE + IF(lstardis) THEN + CALL nxgraro2( 1,zu,zv,nitergrot,zu,zv ) + ELSE + CALL nxgrarot( 1,zu,zv,nitergrot,zu,zv ) + ENDIF + ENDIF + + CALL minmax(iip1*jjp1,zu,umin,ullm ) + CALL minmax(iip1*jjm, zv,vmin,vllm ) + + ullm = ABS ( ullm ) + vllm = ABS ( vllm ) + + zllm = MAX( ullm,vllm ) + z1llm = 1./ zllm + DO ij = 1, ip1jmp1 + zu(ij) = zu(ij)* z1llm + ENDDO + DO ij = 1, ip1jm + zv(ij) = zv(ij)* z1llm + ENDDO + 5 CONTINUE + + 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 + + 20 CONTINUE + +c petit test pour les operateurs non star: +c ---------------------------------------- + +c IF(.NOT.lstardis) THEN + fact = rad*24./REAL(jjm) + fact = fact*fact + PRINT*,'coef u ', fact/cdivu, 1./cdivu + PRINT*,'coef r ', fact/crot , 1./crot + PRINT*,'coef h ', fact/cdivh, 1./cdivh +c ENDIF + +c----------------------------------------------------------------------- +c variation verticale du coefficient de dissipation: +c -------------------------------------------------- + + if (ok_strato .and. llm==39) then + do l=1,llm + pseudoz=8.*log(preff/presnivs(l)) + zvert(l)=1+ + s (tanh((pseudoz-dissip_zref)/dissip_deltaz)+1.)/2. + s *(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 + + + PRINT*,'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 + + PRINT *,' INIDI tetamin dtvr ',tetamin,dtvr,iperiod + idissip = INT( tetamin/( 2.*dtvr*iperiod) ) * iperiod + PRINT *,' INIDI tetamin idissip ',tetamin,idissip + idissip = MAX(iperiod,idissip) + dtdiss = idissip * dtvr + PRINT *,' INIDI idissip dtdiss ',idissip,dtdiss + + DO l = 1,llm + PRINT*,zvert(l),dtdiss*tetaudiv(l),dtdiss*tetaurot(l), + * dtdiss*tetah(l) + ENDDO + +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/inigeom.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/inigeom.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/inigeom.F (revision 1632) @@ -0,0 +1,699 @@ +! +! $Id: inigeom.F 1299 2010-01-20 14:27:21Z fairhead $ +! +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 + DO 32 i = 1,iim + xprp = xprimp025( i ) + xprm = xprimm025( i ) + + ai14 = un4rad2 * coslatp * yprp + ai23 = un4rad2 * coslatm * yprm + 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/dyn3dmem/inigrads.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/inigrads.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/inigrads.F (revision 1632) @@ -0,0 +1,92 @@ +! +! $Header$ +! + subroutine inigrads(if,im + s ,x,fx,xmin,xmax,jm,y,ymin,ymax,fy,lm,z,fz + s ,dt,file,titlel) + + + implicit none + + integer if,im,jm,lm,i,j,l,lnblnk + real x(im),y(jm),z(lm),fx,fy,fz,dt + real xmin,xmax,ymin,ymax + + character file*10,titlel*40 + +#include "gradsdef.h" + +c data unit/66,32,34,36,38,40,42,44,46,48/ + integer nf + save nf + data nf/0/ + + unit(1)=66 + unit(2)=32 + unit(3)=34 + unit(4)=36 + unit(5)=38 + unit(6)=40 + unit(7)=42 + unit(8)=44 + unit(9)=46 + + if (if.le.nf) stop'verifier les appels a inigrads' + + print*,'Entree dans inigrads' + + nf=if + title(if)=titlel + ivar(if)=0 + + fichier(if)=file(1:lnblnk(file)) + + firsttime(if)=.true. + dtime(if)=dt + + iid(if)=1 + ifd(if)=im + imd(if)=im + do i=1,im + xd(i,if)=x(i)*fx + if(xd(i,if).lt.xmin) iid(if)=i+1 + if(xd(i,if).le.xmax) ifd(if)=i + enddo + print*,'On stoke du point ',iid(if),' a ',ifd(if),' en x' + + jid(if)=1 + jfd(if)=jm + jmd(if)=jm + do j=1,jm + yd(j,if)=y(j)*fy + if(yd(j,if).gt.ymax) jid(if)=j+1 + if(yd(j,if).ge.ymin) jfd(if)=j + enddo + print*,'On stoke du point ',jid(if),' a ',jfd(if),' en y' + + print*,'Open de dat' + print*,'file=',file + print*,'fichier(if)=',fichier(if) + + print*,4*(ifd(if)-iid(if))*(jfd(if)-jid(if)) + print*,file(1:lnblnk(file))//'.dat' + + OPEN (unit(if)+1,FILE=file(1:lnblnk(file))//'.dat' + s ,FORM='unformatted', + s ACCESS='direct' + s ,RECL=4*(ifd(if)-iid(if)+1)*(jfd(if)-jid(if)+1)) + + print*,'Open de dat ok' + + lmd(if)=lm + do l=1,lm + zd(l,if)=z(l)*fz + enddo + + irec(if)=0 + + print*,if,imd(if),jmd(if),lmd(if) + print*,'if,imd(if),jmd(if),lmd(if)' + + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/iniprint.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/iniprint.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/iniprint.h (revision 1632) @@ -0,0 +1,11 @@ +! +! $Header$ +! +! +! gestion des impressions de sorties et de débogage +! lunout: unité du fichier dans lequel se font les sorties +! (par defaut 6, la sortie standard) +! prt_level: niveau d'impression souhaité (0 = minimum) +! + INTEGER lunout, prt_level + COMMON /comprint/ lunout, prt_level Index: /LMDZ5/trunk/libf/dyn3dmem/initdynav_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/initdynav_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/initdynav_loc.F (revision 1632) @@ -0,0 +1,279 @@ +! +! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $ +! + subroutine initdynav_loc(day0,anne0,tstep,t_ops,t_wrt) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE IOIPSL +#endif + use parallel + use Write_field + use misc_mod + USE infotrac + use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid, & + & dynhistave_file,dynhistvave_file,dynhistuave_file + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL. Initialisation du fichier histoire moyenne. +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C day0,anne0: date de reference +C tstep : frequence d'ecriture +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + integer*4 day0, anne0 + real tstep, t_ops, t_wrt + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer uhoriid, vhoriid, thoriid + integer zvertiid,zvertiidv,zvertiidu + integer ii,jj + integer zan, dayref + integer :: jjb,jje,jjn + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + + INTEGER :: dynhistave_domain_id + INTEGER :: dynhistvave_domain_id + INTEGER :: dynhistuave_domain_id + + if (adjust) return + +C +C Initialisations +C + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + +! Creation de 3 fichiers pour les differentes grilles horizontales +! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier +! Grille Scalaire + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynhistave_domain_id) + + call histbeg(dynhistave_file,iip1, rlong(:,1), jjn, + . rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, + . zjulian, tstep, thoriid, + . histaveid,dynhistave_domain_id) + + +C Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) +! Grille V + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + IF (pole_sud) jjn=jjn-1 + IF (pole_sud) jje=jje-1 + + do jj = jjb, jje + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynhistvave_domain_id) + + call histbeg(dynhistvave_file,iip1, rlong(:,1), jjn, + . rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, + . zjulian, tstep, vhoriid, + . histvaveid,dynhistvave_domain_id) + +! Grille U + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynhistuave_domain_id) + + call histbeg(dynhistuave_file,iip1, rlong(:,1), jjn, + . rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, + . zjulian, tstep, uhoriid, + . histuaveid,dynhistuave_domain_id) + + +C +C Appel a histvert pour la grille verticale +C + call histvert(histaveid,'presnivs','Niveaux Pression + & approximatifs','mb',llm, presnivs/100., zvertiid,'down') + call histvert(histuaveid,'presnivs','Niveaux Pression + & approximatifs','mb',llm, presnivs/100., zvertiidv,'down') + call histvert(histvaveid,'presnivs','Niveaux Pression + & approximatifs','mb',llm, presnivs/100., zvertiidu,'down') + +C +C Appels a histdef pour la definition des variables a sauvegarder +C +C Vents U +C + call histdef(histuaveid, 'u', 'vent u moyen ', + . 'm/s', iip1, jjp1, uhoriid, llm, 1, llm, zvertiidu, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Vents V +C + call histdef(histvaveid, 'v', 'vent v moyen', + . 'm/s', iip1, jjm, vhoriid, llm, 1, llm, zvertiidv, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Temperature +C + call histdef(histaveid, 'temp', 'temperature moyenne', 'K', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Temperature potentielle +C + call histdef(histaveid, 'theta', 'temperature potentielle', 'K', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + + +C +C Geopotentiel +C + call histdef(histaveid, 'phi', 'geopotentiel moyen', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Traceurs +C +! DO iq=1,nqtot +! call histdef(histaveid, ttext(iq), ttext(iq), '-', +! . iip1, jjn, thoriid, llm, 1, llm, zvertiid, +! . 32, 'ave(X)', t_ops, t_wrt) +! enddo +C +C Masse +C + call histdef(histaveid, 'masse', 'masse', 'kg', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(histaveid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjp1, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C +! call histdef(histaveid, 'phis', 'geopotentiel au sol', '-', +! . iip1, jjn, thoriid, 1, 1, 1, -99, +! . 32, 'ave(X)', t_ops, t_wrt) +C +C Fin +C + call histend(histaveid) + call histend(histuaveid) + call histend(histvaveid) +#else + write(lunout,*)'initdynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/initdynav_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/initdynav_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/initdynav_p.F (revision 1632) @@ -0,0 +1,204 @@ +! +! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $ +! + subroutine initdynav_p(infile,day0,anne0,tstep,t_ops,t_wrt,fileid) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE IOIPSL +#endif + use parallel + use Write_field + use misc_mod + USE infotrac + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL. Initialisation du fichier histoire moyenne. +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep : frequence d'ecriture +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + integer*4 day0, anne0 + real tstep, t_ops, t_wrt + integer fileid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer thoriid, zvertiid + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer ii,jj + integer zan, dayref + integer :: jjb,jje,jjn + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + + INTEGER :: dynave_domain_id + + if (adjust) return +C +C Initialisations +C + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynave_domain_id) + + call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn,tau0, zjulian, tstep, thoriid, + . fileid,dynave_domain_id) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sigss', 'Niveaux sigma','Pa', + . llm, nivsigs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder +C +C Vents U +C + write(6,*)'inithistave',tstep + call histdef(fileid, 'u', 'vents u scalaires moyennes', + . 'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Vents V +C + call histdef(fileid, 'v', 'vents v scalaires moyennes', + . 'm/s', iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Temperature +C + call histdef(fileid, 'temp', 'temperature moyennee', 'K', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Temperature potentielle +C + call histdef(fileid, 'theta', 'temperature potentielle', 'K', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + + +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel moyenne', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Traceurs +C + DO iq=1,nqtot + call histdef(fileid, ttext(iq), ttext(iq), '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + enddo +C +C Masse +C + call histdef(fileid, 'masse', 'masse', 'kg', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'phis', 'geopotentiel au sol', '-', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) +#else + write(lunout,*)'initdynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/initfluxsto_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/initfluxsto_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/initfluxsto_p.F (revision 1632) @@ -0,0 +1,296 @@ +! +! $Id: initfluxsto_p.F 1279 2009-12-10 09:02:56Z fairhead $ +! + subroutine initfluxsto_p + . (infile,tstep,t_ops,t_wrt, + . fileid,filevid,filedid) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE IOIPSL +#endif + use parallel + use Write_field + use misc_mod + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C filevid:ID du fichier netcdf pour la grille v +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + real tstep, t_ops, t_wrt + integer fileid, filevid,filedid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + real nivd(1) + integer tau0 + real zjulian + character*3 str + character*10 ctrac + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1),rl(1,1) + integer uhoriid, vhoriid, thoriid, zvertiid,dhoriid,dvertiid + integer ii,jj + integer zan, idayref + logical ok_sync + integer :: jjb,jje,jjn + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + + INTEGER :: dynu_domain_id + INTEGER :: dynv_domain_id + +C +C Initialisations +C + pi = 4. * atan (1.) + str='q ' + ctrac = 'traceur ' + ok_sync = .true. +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = annee_ref + idayref = day_ref + CALL ymds2ju(zan, 1, idayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonu(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynu_domain_id) + + call histbeg(trim(infile),iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn, tau0, zjulian, tstep, uhoriid, + . fileid,dynu_domain_id) +C +C Creation du fichier histoire pour la grille en V (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) + + + do jj = 1, jjm + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) jje=jj_end-1 + if (pole_sud) jjn=jj_nb-1 + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjm /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynv_domain_id) + + call histbeg('fluxstokev',iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn,tau0, zjulian, tstep, vhoriid, + . filevid,dynv_domain_id) + + rl(1,1) = 1. + + if (mpi_rank==0) then + + call histbeg('defstoke.nc', 1, rl, 1, rl, + . 1, 1, 1, 1, + . tau0, zjulian, tstep, dhoriid, filedid) + + endif +C +C Appel a histhori pour rajouter les autres grilles horizontales +C + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje), + . 'scalar','Grille points scalaires', thoriid) + +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . llm, nivsigs, zvertiid) +C Pour le fichier V + call histvert(filevid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . llm, nivsigs, zvertiid) +c pour le fichier def + nivd(1) = 1 + call histvert(filedid, 'sig_s', 'Niveaux sigma', + . 'sigma_level', + . 1, nivd, dvertiid) + +C +C Appels a histdef pour la definition des variables a sauvegarder + + CALL histdef(fileid, "phis", "Surface geop. height", "-", + . iip1,jjn,thoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(fileid, "aire", "Grid area", "-", + . iip1,jjn,thoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + if (mpi_rank==0) then + + CALL histdef(filedid, "dtvr", "tps dyn", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "istdyn", "tps stock", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + CALL histdef(filedid, "istphy", "tps stock phy", "s", + . 1,1,dhoriid, 1,1,1, -99, 32, + . "once", t_ops, t_wrt) + + endif +C +C Masse +C + call histdef(fileid, 'masse', 'Masse', 'kg', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pbaru +C + call histdef(fileid, 'pbaru', 'flx de masse zonal', 'kg m/s', + . iip1, jjn, uhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Pbarv +C + if (pole_sud) jjn=jj_nb-1 + + call histdef(filevid, 'pbarv', 'flx de masse mer', 'kg m/s', + . iip1, jjn, vhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C w +C + if (pole_sud) jjn=jj_nb + call histdef(fileid, 'w', 'flx de masse vert', 'kg m/s', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Temperature potentielle +C + call histdef(fileid, 'teta', 'temperature potentielle', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C + +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel instantane', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) + call histend(filevid) + call histend(filedid) + if (ok_sync) then + call histsync(fileid) + call histsync(filevid) + call histsync(filedid) + endif + +#else + write(lunout,*)'initfluxsto_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/inithist_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/inithist_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/inithist_loc.F (revision 1632) @@ -0,0 +1,280 @@ +! +! $Id: initdynav_p.F 1279 2009-12-10 09:02:56Z fairhead $ +! + subroutine inithist_loc(day0,anne0,tstep,t_ops,t_wrt) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE IOIPSL +#endif + use parallel + use Write_field + use misc_mod + USE infotrac + use com_io_dyn_mod, only : histid,histvid,histuid, & + & dynhist_file,dynhistv_file,dynhistu_file + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C nq: nombre de traceurs +C +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + integer day0, anne0 + real tstep, t_ops, t_wrt + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer uhoriid, vhoriid, thoriid + integer zvertiid,zvertiidv,zvertiidu + integer ii,jj + integer zan, dayref + integer :: jjb,jje,jjn + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + + INTEGER :: dynhist_domain_id + INTEGER :: dynhistv_domain_id + INTEGER :: dynhistu_domain_id + + if (adjust) return + +C +C Initialisations +C + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + +! Creation de 3 fichiers pour les differentes grilles horizontales +! Restriction de IOIPSL: seulement 2 coordonnees dans le meme fichier +! Grille Scalaire + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynhist_domain_id) + + call histbeg(dynhist_file,iip1, rlong(:,1), jjn, + . rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, + . zjulian, tstep, thoriid, + . histid,dynhist_domain_id) + + +C Creation du fichier histoire pour les grilles en V et U (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) +! Grille V + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + IF (pole_sud) jjn=jjn-1 + IF (pole_sud) jje=jje-1 + + do jj = jjb, jje + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynhistv_domain_id) + + call histbeg(dynhistv_file,iip1, rlong(:,1), jjn, + . rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, + . zjulian, tstep, vhoriid, + . histvid,dynhistv_domain_id) + +! Grille U + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynhistu_domain_id) + + call histbeg(dynhistu_file,iip1, rlong(:,1), jjn, + . rlat(1,jjb:jje), 1, iip1, 1, jjn,tau0, + . zjulian, tstep, uhoriid, + . histuid,dynhistu_domain_id) + + +! ------------------------------------------------------------- +C Appel a histvert pour la grille verticale +! ------------------------------------------------------------- + call histvert(histid, 'presnivs', 'Niveaux pression','mb', + . llm, presnivs/100., zvertiid,'down') + call histvert(histvid, 'presnivs', 'Niveaux pression','mb', + . llm, presnivs/100., zvertiidv,'down') + call histvert(histuid, 'presnivs', 'Niveaux pression','mb', + . llm, presnivs/100., zvertiidu,'down') + +C +! ------------------------------------------------------------- +C Appels a histdef pour la definition des variables a sauvegarder +! ------------------------------------------------------------- +C +C Vents U +C + call histdef(histuid, 'u', 'vent u moyen ', + . 'm/s', iip1, jjp1, uhoriid, llm, 1, llm, zvertiidu, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Vents V +C + call histdef(histvid, 'v', 'vent v moyen', + . 'm/s', iip1, jjm, vhoriid, llm, 1, llm, zvertiidv, + . 32, 'ave(X)', t_ops, t_wrt) + +C +C Temperature +C + call histdef(histid, 'temp', 'temperature moyenne', 'K', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Temperature potentielle +C + call histdef(histid, 'theta', 'temperature potentielle', 'K', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) + + +C +C Geopotentiel +C + call histdef(histid, 'phi', 'geopotentiel moyen', '-', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Traceurs +C +! DO iq=1,nqtot +! call histdef(histid, ttext(iq), ttext(iq), '-', +! . iip1, jjn, thoriid, llm, 1, llm, zvertiid, +! . 32, 'ave(X)', t_ops, t_wrt) +! enddo +C +C Masse +C + call histdef(histid, 'masse', 'masse', 'kg', + . iip1, jjp1, thoriid, llm, 1, llm, zvertiid, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(histid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjp1, thoriid, 1, 1, 1, -99, + . 32, 'ave(X)', t_ops, t_wrt) +C +C Pression au sol +C +! call histdef(histid, 'phis', 'geopotentiel au sol', '-', +! . iip1, jjn, thoriid, 1, 1, 1, -99, +! . 32, 'ave(X)', t_ops, t_wrt) +C +C Fin +C + call histend(histid) + call histend(histuid) + call histend(histvid) +#else + write(lunout,*)'initdynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/inithist_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/inithist_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/inithist_p.F (revision 1632) @@ -0,0 +1,257 @@ +! +! $Id: inithist_p.F 1279 2009-12-10 09:02:56Z fairhead $ +! + subroutine inithist_p(infile,day0,anne0,tstep,t_ops,t_wrt, + . fileid,filevid) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE IOIPSL +#endif + use parallel + use Write_field + use misc_mod + USE infotrac + + implicit none + +C +C Routine d'initialisation des ecritures des fichiers histoires LMDZ +C au format IOIPSL +C +C Appels succesifs des routines: histbeg +C histhori +C histver +C histdef +C histend +C +C Entree: +C +C infile: nom du fichier histoire a creer +C day0,anne0: date de reference +C tstep: duree du pas de temps en seconde +C t_ops: frequence de l'operation pour IOIPSL +C t_wrt: frequence d'ecriture sur le fichier +C +C Sortie: +C fileid: ID du fichier netcdf cree +C filevid:ID du fichier netcdf pour la grille v +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C Arguments +C + character*(*) infile + integer*4 day0, anne0 + real tstep, t_ops, t_wrt + integer fileid, filevid + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer tau0 + real zjulian + integer iq + real rlong(iip1,jjp1), rlat(iip1,jjp1) + integer uhoriid, vhoriid, thoriid, zvertiid + integer ii,jj + integer zan, dayref + integer :: jjb,jje,jjn + +! definition du domaine d'ecriture pour le rebuild + + INTEGER,DIMENSION(2) :: ddid + INTEGER,DIMENSION(2) :: dsg + INTEGER,DIMENSION(2) :: dsl + INTEGER,DIMENSION(2) :: dpf + INTEGER,DIMENSION(2) :: dpl + INTEGER,DIMENSION(2) :: dhs + INTEGER,DIMENSION(2) :: dhe + + INTEGER :: dynu_domain_id + INTEGER :: dynv_domain_id + +C +C Initialisations +C + if (adjust) return + + pi = 4. * atan (1.) +C +C Appel a histbeg: creation du fichier netcdf et initialisations diverses +C + + zan = anne0 + dayref = day0 + CALL ymds2ju(zan, 1, dayref, 0.0, zjulian) + tau0 = itau_dyn + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonu(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjp1 /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynu_domain_id) + + call histbeg(trim(infile),iip1, rlong(:,1), jjn, + . rlat(1,jjb:jje), 1, iip1, 1, jjn, tau0, + . zjulian, tstep, uhoriid, fileid,dynu_domain_id) +C +C Creation du fichier histoire pour la grille en V (oblige pour l'instant, +C IOIPSL ne permet pas de grilles avec des nombres de point differents dans +C un meme fichier) + + do jj = 1, jjm + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatv(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + if (pole_sud) jje=jj_end-1 + if (pole_sud) jjn=jj_nb-1 + + ddid=(/ 1,2 /) + dsg=(/ iip1,jjm /) + dsl=(/ iip1,jjn /) + dpf=(/ 1,jjb /) + dpl=(/ iip1,jje /) + dhs=(/ 0,0 /) + dhe=(/ 0,0 /) + + call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, + . 'box',dynv_domain_id) + + call histbeg('dyn_histv', iip1, rlong(:,1), jjn, rlat(1,jjb:jje), + . 1, iip1, 1, jjn, tau0, zjulian, tstep, vhoriid, + . filevid,dynv_domain_id) +C +C Appel a histhori pour rajouter les autres grilles horizontales +C + + do jj = 1, jjp1 + do ii = 1, iip1 + rlong(ii,jj) = rlonv(ii) * 180. / pi + rlat(ii,jj) = rlatu(jj) * 180. / pi + enddo + enddo + + jjb=jj_begin + jje=jj_end + jjn=jj_nb + + call histhori(fileid, iip1, rlong(:,jjb:jje),jjn,rlat(:,jjb:jje), + . 'scalar','Grille points scalaires', thoriid) +C +C Appel a histvert pour la grille verticale +C + call histvert(fileid, 'sig_s', 'Niveaux sigma','-', + . llm, nivsigs, zvertiid) +C Pour le fichier V + call histvert(filevid, 'sig_s', 'Niveaux sigma','-', + . llm, nivsigs, zvertiid) +C +C Appels a histdef pour la definition des variables a sauvegarder +C +C Vents U +C + jjn=jj_nb + + call histdef(fileid, 'ucov', 'vents u covariants', 'm/s', + . iip1, jjn, uhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Vents V +C + if (pole_sud) jjn=jj_nb-1 + + call histdef(filevid, 'vcov', 'vents v covariants', 'm/s', + . iip1, jjn, vhoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + +C +C Temperature potentielle +C + jjn=jj_nb + + call histdef(fileid, 'teta', 'temperature potentielle', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Geopotentiel +C + call histdef(fileid, 'phi', 'geopotentiel instantane', '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Traceurs +C + DO iq=1,nqtot + call histdef(fileid, ttext(iq), ttext(iq), '-', + . iip1, jjn, thoriid, llm, 1, llm, zvertiid, + . 32, 'inst(X)', t_ops, t_wrt) + enddo +C +C Masse +C + call histdef(fileid, 'masse', 'masse', 'kg', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'ps', 'pression naturelle au sol', 'Pa', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Pression au sol +C + call histdef(fileid, 'phis', 'geopotentiel au sol', '-', + . iip1, jjn, thoriid, 1, 1, 1, -99, + . 32, 'inst(X)', t_ops, t_wrt) +C +C Fin +C + call histend(fileid) + call histend(filevid) +#else + write(lunout,*)'inithist_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/initial0.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/initial0.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/initial0.F (revision 1632) @@ -0,0 +1,12 @@ +! +! $Header$ +! + SUBROUTINE initial0(n,x) + IMPLICIT NONE + INTEGER n,i + REAL x(n) + DO 10 i=1,n + x(i)=0. +10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/integrd_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/integrd_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/integrd_loc.F (revision 1632) @@ -0,0 +1,412 @@ +! +! $Id: integrd_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! + SUBROUTINE integrd_loc + $ ( nq,vcovm1,ucovm1,tetam1,psm1,massem1, + $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis,finvmaold) + USE parallel + USE control_mod + USE mod_filtreg_p + USE write_field_loc + USE write_field + USE integrd_mod + IMPLICIT NONE + + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c objet: +c ------ +c +c Incrementation des tendances dynamiques +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +#include "comvert.h" +#include "logic.h" +#include "temps.h" +#include "serre.h" + include 'mpif.h' + +c Arguments: +c ---------- + + INTEGER nq + + REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) + REAL teta(ijb_u:ije_u,llm) + REAL q(ijb_u:ije_u,llm,nq) + REAL ps0(ijb_u:ije_u),masse(ijb_u:ije_u,llm),phis(ijb_u:ije_u) + + REAL vcovm1(ijb_v:ije_v,llm),ucovm1(ijb_u:ije_u,llm) + REAL tetam1(ijb_u:ije_u,llm),psm1(ijb_u:ije_u) + REAL massem1(ijb_u:ije_u,llm) + + REAL dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm) + REAL dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u) + REAL dq(ijb_u:ije_u,llm,nq), finvmaold(ijb_u:ije_u,llm) + +c Local: +c ------ + + REAL vscr( ijb_v:ije_v ),uscr( ijb_u:ije_u ) + REAL hscr( ijb_u:ije_u ),pscr(ijb_u:ije_u) + REAL massescr( ijb_u:ije_u,llm ), finvmasse(ijb_u:ije_u,llm) + REAL tpn,tps,tppn(iim),tpps(iim) + REAL qpn,qps,qppn(iim),qpps(iim) + + INTEGER l,ij,iq + + REAL SSUM + EXTERNAL SSUM + INTEGER ijb,ije,jjb,jje + LOGICAL :: checksum + LOGICAL,SAVE :: checksum_all=.TRUE. + INTEGER :: stop_it + INTEGER :: ierr,j + +c----------------------------------------------------------------------- +c$OMP BARRIER + if (pole_nord) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + DO ij = 1,iip1 + ucov( ij , l) = 0. + uscr( ij ) = 0. + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF + + if (pole_sud) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + DO ij = 1,iip1 + ucov( ij +ip1jm, l) = 0. + uscr( ij +ip1jm ) = 0. + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF + +c ............ integration de ps .............. + +c CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1) + + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + massescr(ijb:ije,l)=masse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC) + DO 2 ij = ijb,ije + pscr (ij) = ps0(ij) + ps (ij) = psm1(ij) + dt * dp(ij) + 2 CONTINUE +c$OMP END DO +c$OMP BARRIER +c --> ici synchro OPENMP pour ps + + checksum=.TRUE. + stop_it=0 + +c$OMP MASTER +!c$OMP DO SCHEDULE(STATIC) + DO ij = ijb,ije + IF( ps(ij).LT.0. ) THEN + IF (checksum) stop_it=ij + checksum=.FALSE. + ENDIF + ENDDO +!c$OMP END DO NOWAIT + +! CALL MPI_ALLREDUCE(checksum,checksum_all,1, +! & MPI_LOGICAL,MPI_LOR,COMM_LMDZ,ierr) + IF( .NOT. checksum ) THEN + PRINT*,' Au point ij = ',stop_it, ' , pression sol neg. ' + & , ps(stop_it) + STOP' dans integrd' + ENDIF +c$OMP END MASTER +c$OMP BARRIER + IF (.NOT. Checksum_all) THEN + call WriteField_v('int_vcov',vcov) + call WriteField_u('int_ucov',ucov) + call WriteField_u('int_teta',teta) + call WriteField_u('int_ps0',ps0) + call WriteField_u('int_masse',masse) + call WriteField_u('int_phis',phis) + call WriteField_v('int_vcovm1',vcovm1) + call WriteField_u('int_ucovm1',ucovm1) + call WriteField_u('int_tetam1',tetam1) + call WriteField_u('int_psm1',psm1) + call WriteField_u('int_massem1',massem1) + + call WriteField_v('int_dv',dv) + call WriteField_u('int_du',du) + call WriteField_u('int_dteta',dteta) + call WriteField_u('int_dp',dp) + call WriteField_u('int_finvmaold',finvmaold) + do j=1,nq + call WriteField_u('int_q'//trim(int2str(j)), + . q(:,:,j)) + call WriteField_u('int_dq'//trim(int2str(j)), + . dq(:,:,j)) + enddo + STOP + ENDIF + + +c +C$OMP MASTER + if (pole_nord) THEN + + DO ij = 1, iim + tppn(ij) = aire( ij ) * ps( ij ) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + DO ij = 1, iip1 + ps( ij ) = tpn + ENDDO + + ENDIF + + if (pole_sud) THEN + + DO ij = 1, iim + tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm) + ENDDO + tps = SSUM(iim,tpps,1)/apols + DO ij = 1, iip1 + ps(ij+ip1jm) = tps + ENDDO + + ENDIF +c$OMP END MASTER +c$OMP BARRIER +c +c ... Calcul de la nouvelle masse d'air au dernier temps integre t+1 ... +c + + CALL pression_loc ( ip1jmp1, ap, bp, ps, p ) +c$OMP BARRIER + CALL massdair_loc ( p , masse ) + +c CALL SCOPY( ijp1llm , masse, 1, finvmasse, 1 ) + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm + finvmasse(ijb:ije,l)=masse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + jjb=jj_begin + jje=jj_end + CALL filtreg_p( finvmasse,jjb_u,jje_u,jjb,jje, jjp1, llm, + & -2, 2, .TRUE., 1 ) +c + +c ............ integration de ucov, vcov, h .............. + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,llm + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + uscr( ij ) = ucov( ij,l ) + ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l ) + 4 CONTINUE + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 5 ij = ijb,ije + vscr( ij ) = vcov( ij,l ) + vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l ) + 5 CONTINUE + + ijb=ij_begin + ije=ij_end + + DO 6 ij = ijb,ije + hscr( ij ) = teta(ij,l) + teta ( ij,l ) = tetam1(ij,l) * massem1(ij,l) / masse(ij,l) + $ + dt * dteta(ij,l) / masse(ij,l) + 6 CONTINUE + +c .... Calcul de la valeur moyenne, unique aux poles pour teta ...... +c +c + IF (pole_nord) THEN + + DO ij = 1, iim + tppn(ij) = aire( ij ) * teta( ij ,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + + DO ij = 1, iip1 + teta( ij ,l) = tpn + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO ij = 1, iim + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta(ij+ip1jm,l) = tps + ENDDO + + ENDIF +c + + IF(leapf) THEN +c CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 ) +c CALL SCOPY ( ip1jm, vscr(1), 1, vcovm1(1, l), 1 ) +c CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 ) + ijb=ij_begin + ije=ij_end + ucovm1(ijb:ije,l)=uscr(ijb:ije) + tetam1(ijb:ije,l)=hscr(ijb:ije) + if (pole_sud) ije=ij_end-iip1 + vcovm1(ijb:ije,l)=vscr(ijb:ije) + + END IF + + 10 CONTINUE +c$OMP END DO NOWAIT + +c +c ....... integration de q ...... +c + ijb=ij_begin + ije=ij_end + + if (planet_type.eq."earth") then +! Earth-specific treatment of first 2 tracers (water) +c$OMP BARRIER +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + deltap(ij,l) = p(ij,l) - p(ij,l+1) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c$OMP BARRIER + + CALL qminimum_loc( q, nq, deltap ) + endif ! of if (planet_type.eq."earth") +c +c ..... Calcul de la valeur moyenne, unique aux poles pour q ..... +c +c$OMP BARRIER + IF (pole_nord) THEN + + DO iq = 1, nq + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + + DO ij = 1, iim + qppn(ij) = aire( ij ) * q( ij ,l,iq) + ENDDO + qpn = SSUM(iim,qppn,1)/apoln + + DO ij = 1, iip1 + q( ij ,l,iq) = qpn + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO iq = 1, nq + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + + DO ij = 1, iim + qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq) + ENDDO + qps = SSUM(iim,qpps,1)/apols + + DO ij = 1, iip1 + q(ij+ip1jm,l,iq) = qps + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ENDDO + + ENDIF + +c CALL SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT +c +c +c ..... FIN de l'integration de q ....... + +15 continue + +c$OMP DO SCHEDULE(STATIC) + DO ij=ijb,ije + ps0(ij)=ps(ij) + ENDDO +c$OMP END DO NOWAIT + +c ................................................................. + + + IF( leapf ) THEN +c CALL SCOPY ( ip1jmp1 , pscr , 1, psm1 , 1 ) +c CALL SCOPY ( ip1jmp1*llm, massescr, 1, massem1, 1 ) +c$OMP DO SCHEDULE(STATIC) + DO ij=ijb,ije + psm1(ij)=pscr(ij) + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + massem1(ijb:ije,l)=massescr(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + END IF +c$OMP BARRIER + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/integrd_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/integrd_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/integrd_mod.F90 (revision 1632) @@ -0,0 +1,46 @@ +MODULE integrd_mod + + REAL,POINTER,SAVE :: p(:,:) + REAL,POINTER,SAVE :: deltap(:,:) + REAL,POINTER,SAVE :: ps(:) + + + +CONTAINS + + SUBROUTINE integrd_allocate + USE bands + USE allocate_field + USE parallel + USE dimensions + USE advect_new_mod,ONLY : advect_new_allocate + IMPLICIT NONE + TYPE(distrib),POINTER :: d + + + d=>distrib_caldyn + CALL allocate_u(p,llmp1,d) + CALL allocate_u(deltap,llm,d) + CALL allocate_u(ps,d) + + + END SUBROUTINE integrd_allocate + + SUBROUTINE integrd_switch_caldyn(dist) + USE allocate_field + USE bands + USE parallel + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(p,distrib_caldyn,dist) + CALL switch_u(deltap,distrib_caldyn,dist) + CALL switch_u(ps,distrib_caldyn,dist) + + + + END SUBROUTINE integrd_switch_caldyn + + + +END MODULE integrd_mod Index: /LMDZ5/trunk/libf/dyn3dmem/inter_barxy_m.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/inter_barxy_m.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/inter_barxy_m.F90 (revision 1632) @@ -0,0 +1,450 @@ +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 modèle (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 exprimées 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) = AMOD( 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/dyn3dmem/interpost.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/interpost.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/interpost.F (revision 1632) @@ -0,0 +1,45 @@ +! +! $Header$ +! + subroutine interpost(q,qppm) + + implicit none + + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + +c Arguments + real q(iip1,jjp1,llm) + real qppm(iim,jjp1,llm) +c Local + integer l,i,j + +c RE-INVERSION DES NIVEAUX +c le programme ppm3d travaille avec une 3ème coordonnée inversée par rapport +c de celle du LMDZ: z=1<=>niveau max, z=llm+1<=>surface +c On passe donc des niveaux de Lin à ceux du LMDZ + + do l=1,llm + do j=1,jjp1 + do i=1,iim + q(i,j,l)=qppm(i,j,llm-l+1) + enddo + enddo + enddo + +c BOUCLAGE EN LONGITUDE PAS EFFECTUE DANS PPM3D + + do l=1,llm + do j=1,jjp1 + q(iip1,j,l)=q(1,j,l) + enddo + enddo + + + return + + end Index: /LMDZ5/trunk/libf/dyn3dmem/interpre.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/interpre.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/interpre.F (revision 1632) @@ -0,0 +1,132 @@ +! +! $Id: interpre.F 1299 2010-01-20 14:27:21Z fairhead $ +! + 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/dyn3dmem/invert_lat.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/invert_lat.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/invert_lat.F90 (revision 1632) @@ -0,0 +1,21 @@ + +SUBROUTINE invert_lat(xsize,ysize,vsize,field) + + IMPLICIT NONE + +! Input variables + INTEGER, INTENT(IN) :: xsize,ysize,vsize + REAL, DIMENSION (xsize,ysize,vsize), INTENT(INOUT) :: field +! Local variables + REAL, DIMENSION (xsize,ysize,vsize) :: f_aux + INTEGER :: l,j + + DO l=1,vsize + DO j=1,ysize + f_aux(:,j,l)=field(:,ysize+1-j,l) + END DO + END DO + + field=f_aux + + END SUBROUTINE invert_lat Index: /LMDZ5/trunk/libf/dyn3dmem/ismax.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/ismax.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/ismax.F (revision 1632) @@ -0,0 +1,24 @@ +! +! $Header$ +! + function ismax(n,sx,incx) +c + IMPLICIT NONE +c + INTEGER n,i,incx,ismax,ix + real sx((n-1)*incx+1),sxmax +c + ix=1 + ismax=1 + sxmax=sx(1) + do 10 i=1,n-1 + ix=ix+incx + if(sx(ix).gt.sxmax) then + sxmax=sx(ix) + ismax=i+1 + endif +10 continue +c + return + end + Index: /LMDZ5/trunk/libf/dyn3dmem/ismin.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/ismin.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/ismin.F (revision 1632) @@ -0,0 +1,24 @@ +! +! $Header$ +! + FUNCTION ismin(n,sx,incx) +c + IMPLICIT NONE +c + integer n,i,incx,ismin,ix + real sx((n-1)*incx+1),sxmin +c + ix=1 + ismin=1 + sxmin=sx(1) + DO i=1,n-1 + ix=ix+incx + if(sx(ix).lt.sxmin) then + sxmin=sx(ix) + ismin=i+1 + endif + ENDDO +c + return + end +C Index: /LMDZ5/trunk/libf/dyn3dmem/juldate.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/juldate.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/juldate.F (revision 1632) @@ -0,0 +1,33 @@ +! +! $Header$ +! + subroutine juldate(ian,imoi,ijou,oh,om,os,tjd,tjdsec) +c Sous-routine de changement de date: +c gregorien>>>date julienne +c En entree:an,mois,jour,heure,min.,sec. +c En sortie:tjd + implicit real (a-h,o-z) + frac=((os/60.+om)/60.+oh)/24. + ojou=dfloat(ijou)+frac + year=dfloat(ian) + rmon=dfloat(imoi) + if (imoi .le. 2) then + year=year-1. + rmon=rmon+12. + endif + cf=year+(rmon/100.)+(ojou/10000.) + if (cf .ge. 1582.1015) then + a=int(year/100) + b=2-a+int(a/4) + else + b=0 + endif + tjd=int(365.25*year)+int(30.6001*(rmon+1))+int(ojou) + + +1720994.5+b + tjdsec=(ojou-int(ojou))+(tjd-int(tjd)) + tjd=int(tjd)+int(tjdsec) + tjdsec=tjdsec-int(tjdsec) + return + end + + Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien.F (revision 1632) @@ -0,0 +1,40 @@ +! +! $Header$ +! + SUBROUTINE laplacien ( klevel, teta, divgra ) +c +c P. Le Van +c +c ************************************************************ +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ......... variables en arguments .............. +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) +c +c ............ variables locales .............. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ....................................................... + + +c + CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + CALL filtreg( divgra, jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad ( klevel,divgra, ghx , ghy ) + CALL divergf ( klevel, ghx , ghy , divgra ) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien_gam.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien_gam.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien_gam.F (revision 1632) @@ -0,0 +1,53 @@ +! +! $Header$ +! + SUBROUTINE laplacien_gam ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, teta, divgra ) + +c P. Le Van +c +c ************************************************************ +c +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............ variables en arguments .......... +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) + REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1), + * unsapolnga, unsapolsga +c +c ........... variables locales ................. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ...................................................... + +c +c +c ... cvuscugam = ( cvu/ cu ) ** (- gamdissip ) +c ... cuvscvgam = ( cuv/ cv ) ** (- gamdissip ) calcules dans inigeom .. +c ... unsairegam = 1. / aire ** (- gamdissip ) +c + + CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) +c + CALL grad ( klevel, divgra, ghx, ghy ) +c + CALL diverg_gam ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, ghx , ghy , divgra ) + +c + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien_gam_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien_gam_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien_gam_loc.F (revision 1632) @@ -0,0 +1,65 @@ + SUBROUTINE laplacien_gam_loc ( klevel, cuvsga, cvusga, unsaigam, + * unsapolnga, unsapolsga, teta, divgra ) + +c P. Le Van +c +c ************************************************************ +c +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............ variables en arguments .......... +c + INTEGER klevel + REAL teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel ) + REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ) + REAL unsaigam(ip1jmp1) + REAL unsapolnga, unsapolsga +c +c ........... variables locales ................. +c + REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm) +c ...................................................... + + INTEGER :: ijb,ije + INTEGER :: l +c +c +c ... cvuscugam = ( cvu/ cu ) ** (- gamdissip ) +c ... cuvscvgam = ( cuv/ cv ) ** (- gamdissip ) calcules dans inigeom .. +c ... unsairegam = 1. / aire ** (- gamdissip ) +c + +c CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud ) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,klevel + divgra(ijb:ije,l)=teta(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c + CALL grad_loc ( klevel, divgra, ghx, ghy ) +c + CALL diverg_gam_loc ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, ghx , ghy , divgra ) + +c + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien_gam_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien_gam_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien_gam_p.F (revision 1632) @@ -0,0 +1,65 @@ + SUBROUTINE laplacien_gam_p ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, teta, divgra ) + +c P. Le Van +c +c ************************************************************ +c +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............ variables en arguments .......... +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) + REAL cuvsga(ip1jm) , cvusga( ip1jmp1 ),unsaigam(ip1jmp1), + * unsapolnga, unsapolsga +c +c ........... variables locales ................. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ...................................................... + + INTEGER :: ijb,ije + INTEGER :: l +c +c +c ... cvuscugam = ( cvu/ cu ) ** (- gamdissip ) +c ... cuvscvgam = ( cuv/ cv ) ** (- gamdissip ) calcules dans inigeom .. +c ... unsairegam = 1. / aire ** (- gamdissip ) +c + +c CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud ) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,klevel + divgra(ijb:ije,l)=teta(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c + CALL grad_p ( klevel, divgra, ghx, ghy ) +c + CALL diverg_gam_p ( klevel, cuvsga, cvusga, unsaigam , + * unsapolnga, unsapolsga, ghx , ghy , divgra ) + +c + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien_loc.F (revision 1632) @@ -0,0 +1,58 @@ + SUBROUTINE laplacien_loc ( klevel, teta, divgra ) +c +c P. Le Van +c +c ************************************************************ +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + USE mod_filtreg_p + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ......... variables en arguments .............. +c + INTEGER klevel + REAL teta( ijb_u:ije_u,klevel ), divgra( ijb_u:ije_u,klevel ) + INTEGER :: l +c +c ............ variables locales .............. +c + REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm) +c ....................................................... + + + INTEGER :: ijb,ije,jjb,jje +c +c CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud ) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,klevel + divgra(ijb:ije,l)=teta(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + jjb=jj_begin-1 + jje=jj_end+1 + if (pole_nord) jjb=jj_begin + if (pole_sud ) jje=jj_end + + CALL filtreg_p( divgra,jjb_u,jje_u,jjb,jje,jjp1, + & klevel, 2, 1, .TRUE., 1 ) + CALL grad_loc ( klevel,divgra, ghx , ghy ) + CALL divergf_loc ( klevel, ghx , ghy , divgra ) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien_p.F (revision 1632) @@ -0,0 +1,56 @@ + SUBROUTINE laplacien_p ( klevel, teta, divgra ) +c +c P. Le Van +c +c ************************************************************ +c .... calcul de (div( grad )) de teta ..... +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ......... variables en arguments .............. +c + INTEGER klevel + REAL teta( ip1jmp1,klevel ), divgra( ip1jmp1,klevel ) + INTEGER :: l +c +c ............ variables locales .............. +c + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ....................................................... + + + INTEGER :: ijb,ije,jjb,jje +c +c CALL SCOPY ( ip1jmp1 * klevel, teta, 1, divgra, 1 ) + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud ) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,klevel + divgra(ijb:ije,l)=teta(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + jjb=jj_begin-1 + jje=jj_end+1 + if (pole_nord) jjb=jj_begin + if (pole_sud ) jje=jj_end + + CALL filtreg_p( divgra,jjb,jje,jjp1, klevel, 2, 1, .TRUE., 1 ) + CALL grad_p ( klevel,divgra, ghx , ghy ) + CALL divergf_p ( klevel, ghx , ghy , divgra ) + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien_rot.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien_rot.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien_rot.F (revision 1632) @@ -0,0 +1,39 @@ +! +! $Header$ +! + SUBROUTINE laplacien_rot ( klevel, rotin, rotout,ghx,ghy ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de ( rotat x nxgrad ) du rotationnel rotin . +c ************************************************************ +c +c klevel et rotin sont des arguments d'entree pour le s-prog +c rotout est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c .......... variables en arguments ............. +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c .......... variables locales ................ +c + REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel) +c ........................................................ +c +c + CALL filtreg ( rotin , jjm, klevel, 2, 1, .FALSE., 1 ) + + CALL nxgrad ( klevel, rotin, ghx , ghy ) + CALL rotatf ( klevel, ghx , ghy , rotout ) +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien_rot_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien_rot_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien_rot_loc.F (revision 1632) @@ -0,0 +1,47 @@ + SUBROUTINE laplacien_rot_loc ( klevel, rotin, rotout,ghx,ghy ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de ( rotat x nxgrad ) du rotationnel rotin . +c ************************************************************ +c +c klevel et rotin sont des arguments d'entree pour le s-prog +c rotout est un argument de sortie pour le s-prog +c + USE parallel + USE mod_filtreg_p + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c .......... variables en arguments ............. +c + INTEGER klevel + REAL rotin(ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel ) +c +c .......... variables locales ................ +c + REAL ghy(ijb_v:ije_v,klevel), ghx(ijb_u:ije_u,klevel) +c ........................................................ +c +c + INTEGER :: ijb,ije,jjb,jje + + jjb=jj_begin-1 + jje=jj_end+1 + + if (pole_nord) jjb=jj_begin + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p ( rotin ,jjb_v,jje_v,jjb,jje,jjm, + & klevel,2, 1, .FALSE., 1) + + CALL nxgrad_loc ( klevel, rotin, ghx , ghy ) + CALL rotatf_loc ( klevel, ghx , ghy , rotout ) +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien_rot_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien_rot_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien_rot_p.F (revision 1632) @@ -0,0 +1,45 @@ + SUBROUTINE laplacien_rot_p ( klevel, rotin, rotout,ghx,ghy ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de ( rotat x nxgrad ) du rotationnel rotin . +c ************************************************************ +c +c klevel et rotin sont des arguments d'entree pour le s-prog +c rotout est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c .......... variables en arguments ............. +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c .......... variables locales ................ +c + REAL ghy(ip1jm,klevel), ghx(ip1jmp1,klevel) +c ........................................................ +c +c + INTEGER :: ijb,ije,jjb,jje + + jjb=jj_begin-1 + jje=jj_end+1 + + if (pole_nord) jjb=jj_begin + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p ( rotin ,jjb,jje,jjm, klevel,2, 1, .FALSE., 1) + + CALL nxgrad_p ( klevel, rotin, ghx , ghy ) + CALL rotatf_p ( klevel, ghx , ghy , rotout ) +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien_rotgam.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien_rotgam.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien_rotgam.F (revision 1632) @@ -0,0 +1,44 @@ +! +! $Header$ +! + SUBROUTINE laplacien_rotgam ( klevel, rotin, rotout ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de (rotat x nxgrad)_gam du rotationnel rotin .. +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............. variables en arguments ........... +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c ............ variables locales ............... +c + INTEGER l, ij + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ........................................................ +c +c + + CALL nxgrad_gam ( klevel, rotin, ghx , ghy ) + CALL rotat_nfil ( klevel, ghx , ghy , rotout ) +c + DO l = 1, klevel + DO ij = 1, ip1jm + rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien_rotgam_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien_rotgam_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien_rotgam_loc.F (revision 1632) @@ -0,0 +1,48 @@ + SUBROUTINE laplacien_rotgam_loc ( klevel, rotin, rotout ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de (rotat x nxgrad)_gam du rotationnel rotin .. +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............. variables en arguments ........... +c + INTEGER klevel + REAL rotin( ijb_v:ije_v,klevel ), rotout( ijb_v:ije_v,klevel ) +c +c ............ variables locales ............... +c + INTEGER l, ij + REAL ghy(ijb_v:ije_v,llm), ghx(ijb_u:ije_u,llm) +c ........................................................ +c + INTEGER :: ijb,ije + +c + + CALL nxgrad_gam_loc ( klevel, rotin, ghx , ghy ) + CALL rotat_nfil_loc ( klevel, ghx , ghy , rotout ) +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/laplacien_rotgam_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/laplacien_rotgam_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/laplacien_rotgam_p.F (revision 1632) @@ -0,0 +1,48 @@ + SUBROUTINE laplacien_rotgam_p ( klevel, rotin, rotout ) +c +c P. Le Van +c +c ************************************************************ +c ... calcul de (rotat x nxgrad)_gam du rotationnel rotin .. +c ************************************************************ +c klevel et teta sont des arguments d'entree pour le s-prog +c divgra est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + +c +c ............. variables en arguments ........... +c + INTEGER klevel + REAL rotin( ip1jm,klevel ), rotout( ip1jm,klevel ) +c +c ............ variables locales ............... +c + INTEGER l, ij + REAL ghy(ip1jm,llm), ghx(ip1jmp1,llm) +c ........................................................ +c + INTEGER :: ijb,ije + +c + + CALL nxgrad_gam_p ( klevel, rotin, ghx , ghy ) + CALL rotat_nfil_p ( klevel, ghx , ghy , rotout ) +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + rotout(ij,l) = rotout(ij,l) * unsairz_gam(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/leapfrog_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/leapfrog_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/leapfrog_loc.F (revision 1632) @@ -0,0 +1,1613 @@ +! +! $Id: leapfrog_p.F 1299 2010-01-20 14:27:21Z fairhead $ +! +c +c +#define DEBUG_IO +#undef DEBUG_IO + + + SUBROUTINE leapfrog_loc(ucov0,vcov0,teta0,ps0, + & masse0,phis0,q0,clesphy0, + & time_0) + + USE misc_mod + USE parallel + USE times + USE mod_hallo + USE Bands + USE Write_Field + USE Write_Field_p + USE vampir + USE timer_filtre, ONLY : print_filtre_timer + USE infotrac + USE guide_loc_mod, ONLY : guide_main + USE getparam + USE control_mod + USE mod_filtreg_p + USE write_field_loc + USE allocate_field + USE call_dissip_mod, ONLY : call_dissip + USE call_calfis_mod, ONLY : call_calfis + USE leapfrog_mod + IMPLICIT NONE + +c ...... Version du 10/01/98 .......... + +c avec coordonnees verticales hybrides +c avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) + +c======================================================================= +c +c Auteur: P. Le Van /L. Fairhead/F.Hourdin +c ------- +c +c Objet: +c ------ +c +c GCM LMD nouvelle grille +c +c======================================================================= +c +c ... Dans inigeom , nouveaux calculs pour les elongations cu , cv +c et possibilite d'appeler une fonction f(y) a derivee tangente +c hyperbolique a la place de la fonction a derivee sinusoidale. + +c ... Possibilite de choisir le shema pour l'advection de +c q , en modifiant iadv dans traceur.def (10/02) . +c +c Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) +c Pour Van-Leer iadv=10 +c +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comdissnew.h" +#include "comvert.h" +#include "comgeom.h" +#include "logic.h" +#include "temps.h" +#include "ener.h" +#include "description.h" +#include "serre.h" +#include "com_io_dyn.h" +#include "iniprint.h" +#include "academic.h" + include "mpif.h" + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0( longcles ) + + real zqmin,zqmax + +c variables dynamiques + REAL :: vcov0(ijb_v:ije_v,llm),ucov0(ijb_u:ije_u,llm) ! vents covariants + REAL :: teta0(ijb_u:ije_u,llm) ! temperature potentielle + REAL :: q0(ijb_u:ije_u,llm,nqtot) ! champs advectes + REAL :: ps0(ijb_u:ije_u) ! pression au sol + REAL :: masse0(ijb_u:ije_u,llm) ! masse d'air + REAL :: phis0(ijb_u:ije_u) ! geopotentiel au sol + +! REAL,SAVE,ALLOCATABLE :: p (:,: ) ! pression aux interfac.des couches +! REAL,SAVE,ALLOCATABLE :: pks(:) ! exner au sol +! REAL,SAVE,ALLOCATABLE :: pk(:,:) ! exner au milieu des couches +! REAL,SAVE,ALLOCATABLE :: pkf(:,:) ! exner filt.au milieu des couches +! REAL,SAVE,ALLOCATABLE :: phi(:,:) ! geopotentiel +! REAL,SAVE,ALLOCATABLE :: w(:,:) ! vitesse verticale + +c variables dynamiques intermediaire pour le transport +! REAL,SAVE,ALLOCATABLE :: pbaru(:,:),pbarv(:,:) !flux de masse + +c variables dynamiques au pas -1 +! REAL,SAVE,ALLOCATABLE :: vcovm1(:,:),ucovm1(:,:) +! REAL,SAVE,ALLOCATABLE :: tetam1(:,:),psm1(:) +! REAL,SAVE,ALLOCATABLE :: massem1(:,:) + +c tendances dynamiques +! REAL,SAVE,ALLOCATABLE :: dv(:,:),du(:,:) +! REAL,SAVE,ALLOCATABLE :: dteta(:,:),dp(:) +! REAL,DIMENSION(:,:,:), ALLOCATABLE, SAVE :: dq + +c tendances de la dissipation +! REAL,SAVE,ALLOCATABLE :: dvdis(:,:),dudis(:,:) +! REAL,SAVE,ALLOCATABLE :: dtetadis(:,:) + +c tendances physiques +! REAL,SAVE,ALLOCATABLE :: dvfi(:,:),dufi(:,:) +! REAL,SAVE,ALLOCATABLE :: dtetafi(:,:) +! REAL,SAVE,ALLOCATABLE :: dpfi(:) +! REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: dqfi + +c variables pour le fichier histoire + REAL dtav ! intervalle de temps elementaire + + REAL tppn(iim),tpps(iim),tpn,tps +c + INTEGER itau,itaufinp1,iav +! INTEGER iday ! jour julien + REAL time + + REAL SSUM + REAL time_0 +! REAL,SAVE,ALLOCATABLE :: finvmaold(:,:) + +cym LOGICAL lafin + LOGICAL :: lafin + INTEGER ij,iq,l + INTEGER ik + + real time_step, t_wrt, t_ops + +! jD_cur: jour julien courant +! jH_cur: heure julienne courante + REAL :: jD_cur, jH_cur + INTEGER :: an, mois, jour + REAL :: secondes + + LOGICAL first,callinigrads + + data callinigrads/.true./ + character*10 string10 + +! REAL,SAVE,ALLOCATABLE :: alpha(:,:),beta(:,:) +! REAL,SAVE,ALLOCATABLE :: flxw(:,:) ! flux de masse verticale + +c+jld variables test conservation energie +! REAL,SAVE,ALLOCATABLE :: ecin(:,:),ecin0(:,:) +C Tendance de la temp. potentiel d (theta)/ d t due a la +C tansformation d'energie cinetique en energie thermique +C cree par la dissipation +! REAL,SAVE,ALLOCATABLE :: dtetaecdt(:,:) +! REAL,SAVE,ALLOCATABLE :: vcont(:,:),ucont(:,:) +! REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:) + REAL d_h_vcol, d_qt, d_qw, d_ql, d_ec + CHARACTER*15 ztit +!! INTEGER ip_ebil_dyn ! PRINT level for energy conserv. diag. +! SAVE ip_ebil_dyn +! DATA ip_ebil_dyn/0/ +c-jld + + character*80 dynhist_file, dynhistave_file + character*20 modname + character*80 abort_message + + + logical,PARAMETER :: dissip_conservative=.TRUE. + + INTEGER testita + PARAMETER (testita = 9) + + logical , parameter :: flag_verif = .false. + +c declaration liees au parallelisme + INTEGER :: ierr + LOGICAL :: FirstCaldyn + LOGICAL :: FirstPhysic + INTEGER :: ijb,ije,j,i + type(Request) :: TestRequest + type(Request) :: Request_Dissip + type(Request) :: Request_physic + + INTEGER :: true_itau + LOGICAL :: verbose=.true. + INTEGER :: iapptrac + INTEGER :: AdjustCount +! INTEGER :: var_time + LOGICAL :: ok_start_timer=.FALSE. + LOGICAL, SAVE :: firstcall=.TRUE. + TYPE(distrib),SAVE :: new_dist + +c$OMP MASTER + ItCount=0 +c$OMP END MASTER + true_itau=0 + FirstCaldyn=.TRUE. + FirstPhysic=.TRUE. + iapptrac=0 + AdjustCount = 0 + lafin=.false. + + itaufin = nday*day_step + itaufinp1 = itaufin +1 + modname="leapfrog_p" + + itau = 0 + CALL init_nan + CALL leapfrog_allocate + ucov=ucov0 + vcov=vcov0 + teta=teta0 + ps=ps0 + masse=masse0 + phis=phis0 + q=q0 + +! iday = day_ini+itau/day_step +! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 +! IF(time.GT.1.) THEN +! time = time-1. +! iday = iday+1 +! ENDIF + +c Allocate variables depending on dynamic variable nqtot +!c$OMP MASTER +! +! ALLOCATE(p(ijb_u:ije_u,llmp1)) +! ALLOCATE(pks(ijb_u:ije_u)) +! ALLOCATE(pk(ijb_u:ije_u,llm)) +! ALLOCATE(pkf(ijb_u:ije_u,llm)) +! ALLOCATE(phi(ijb_u:ije_u,llm)) +! ALLOCATE(w(ijb_u:ije_u,llm)) +! ALLOCATE(pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)) +! ALLOCATE(vcovm1(ijb_v:ije_v,llm),ucovm1(ijb_u:ije_u,llm)) +! ALLOCATE(tetam1(ijb_u:ije_u,llm),psm1(ijb_u:ije_u)) +! ALLOCATE(massem1(ijb_u:ije_u,llm)) +! ALLOCATE(dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm)) +! ALLOCATE(dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u)) +! ALLOCATE(dvdis(ijb_v:ije_v,llm),dudis(ijb_u:ije_u,llm)) +! ALLOCATE(dtetadis(ijb_u:ije_u,llm)) +! ALLOCATE(dvfi(ijb_v:ije_v,llm),dufi(ijb_u:ije_u,llm)) +! ALLOCATE(dtetafi(ijb_u:ije_u,llm)) +! ALLOCATE(dpfi(ijb_u:ije_u)) +! ALLOCATE(dq(ijb_u:ije_u,llm,nqtot)) +! ALLOCATE(dqfi(ijb_u:ije_u,llm,nqtot)) +! ALLOCATE(dqfi_tmp(iip1,llm,nqtot)) +! ALLOCATE(finvmaold(ijb_u:ije_u,llm)) +! ALLOCATE(alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm)) +! ALLOCATE(flxw(ijb_u:ije_u,llm)) +! ALLOCATE(ecin(ijb_u:ije_u,llm),ecin0(ijb_u:ije_u,llm)) +! ALLOCATE(dtetaecdt(ijb_u:ije_u,llm)) +! ALLOCATE(vcont(ijb_v:ije_v,llm),ucont(ijb_u:ije_u,llm)) +! ALLOCATE(vnat(ijb_v:ije_v,llm),unat(ijb_u:ije_u,llm)) +!c$OMP END MASTER +!c$OMP BARRIER + +! CALL dynredem1_loc("restart.nc",0.0, +! & vcov,ucov,teta,q,masse,ps) + + +c----------------------------------------------------------------------- +c On initialise la pression et la fonction d'Exner : +c -------------------------------------------------- + +c$OMP MASTER + dq=0. + CALL pression ( ijnb_u, ap, bp, ps, p ) +c$OMP END MASTER + CALL exner_hyb_loc( ijnb_u, ps, p,alpha,beta, pks, pk, pkf) + +c----------------------------------------------------------------------- +c Debut de l'integration temporelle: +c ---------------------------------- +c et du parallelisme !! + + 1 CONTINUE + + jD_cur = jD_ref + day_ini - day_ref + int (itau * dtvr / daysec) + jH_cur = jH_ref + & + & (itau * dtvr / daysec - int(itau * dtvr / daysec)) + +#ifdef CPP_IOIPSL + if (ok_guide) then +!$OMP MASTER + call guide_main(itau,ucov,vcov,teta,q,masse,ps) +!$OMP END MASTER +!$OMP BARRIER + endif +#endif + + +c +c IF( MOD( itau, 10* day_step ).EQ.0 ) THEN +c CALL test_period ( ucov,vcov,teta,q,p,phis ) +c PRINT *,' ---- Test_period apres continue OK ! -----', itau +c ENDIF +c +cym CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 ) +cym CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 ) +cym CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 ) +cym CALL SCOPY( ijp1llm,masse, 1, massem1, 1 ) +cym CALL SCOPY( ip1jmp1, ps , 1, psm1 , 1 ) + + if (FirstCaldyn) then +c$OMP MASTER + ucovm1=ucov + vcovm1=vcov + tetam1= teta + massem1= masse + psm1= ps + + finvmaold = masse +c$OMP END MASTER +c$OMP BARRIER + CALL filtreg_p ( finvmaold ,jjb_u,jje_u,jjb_u,jje_u,jjp1, llm, + & -2,2, .TRUE., 1 ) + else +! Save fields obtained at previous time step as '...m1' + ijb=ij_begin + ije=ij_end + +c$OMP MASTER + psm1 (ijb:ije) = ps (ijb:ije) +c$OMP END MASTER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + ije=ij_end + ucovm1 (ijb:ije,l) = ucov (ijb:ije,l) + tetam1 (ijb:ije,l) = teta (ijb:ije,l) + massem1 (ijb:ije,l) = masse (ijb:ije,l) + finvmaold(ijb:ije,l)=masse(ijb:ije,l) + + if (pole_sud) ije=ij_end-iip1 + vcovm1(ijb:ije,l) = vcov (ijb:ije,l) + + + ENDDO +c$OMP ENDDO + + + CALL filtreg_p(finvmaold ,jjb_u,jje_u,jj_begin,jj_end,jjp1, + . llm, -2,2, .TRUE., 1 ) + + endif ! of if (FirstCaldyn) + + forward = .TRUE. + leapf = .FALSE. + dt = dtvr + +c ... P.Le Van .26/04/94 .... + +cym CALL SCOPY ( ijp1llm, masse, 1, finvmaold, 1 ) +cym CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 ) + +cym ne sert a rien +cym call minmax(ijp1llm,q(:,:,3),zqmin,zqmax) + + 2 CONTINUE + +c$OMP MASTER + ItCount=ItCount+1 + if (MOD(ItCount,1)==0) then + debug=.true. + else + debug=.false. + endif +c$OMP END MASTER +c----------------------------------------------------------------------- + +c date: +c ----- + + +c gestion des appels de la physique et des dissipations: +c ------------------------------------------------------ +c +c ... P.Le Van ( 6/02/95 ) .... + + apphys = .FALSE. + statcl = .FALSE. + conser = .FALSE. + apdiss = .FALSE. + + IF( purmats ) THEN + IF( MOD(itau,iconser) .EQ.0.AND. forward ) conser = .TRUE. + IF( MOD(itau,idissip ).EQ.0.AND..NOT.forward ) apdiss = .TRUE. + IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward + s .and. iflag_phys.EQ.1 ) apphys = .TRUE. + ELSE + IF( MOD(itau ,iconser) .EQ. 0 ) conser = .TRUE. + IF( MOD(itau+1,idissip) .EQ. 0 ) apdiss = .TRUE. + IF( MOD(itau+1,iphysiq).EQ.0.AND.iflag_phys.EQ.1) apphys=.TRUE. + END IF + +cym ---> Pour le moment +cym apphys = .FALSE. + statcl = .FALSE. + conser = .FALSE. + + if (firstCaldyn) then +c$OMP MASTER + call Set_Distrib(distrib_caldyn) +c$OMP END MASTER +c$OMP BARRIER + firstCaldyn=.FALSE. +cym call InitTime +c$OMP MASTER + call Init_timer +c$OMP END MASTER + endif + +c$OMP MASTER + IF (ok_start_timer) THEN + CALL InitTime +! ok_start_timer=.FALSE. + ok_start_timer=.TRUE. + ENDIF +c$OMP END MASTER + + +!ym PAS D'AJUSTEMENT POUR LE MOMENT + if (Adjust) then + AdjustCount=AdjustCount+1 +! if (iapptrac==iapp_tracvl .and. (forward. OR . leapf) +! & .and. itau/iphysiq>2 .and. Adjustcount>30) then + if (Adjustcount>1) then + AdjustCount=0 +c$OMP MASTER + call allgather_timer_average + verbose=.TRUE. + if (Verbose) then + + print *,'*********************************' + print *,'****** TIMER CALDYN ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_caldyn(i), + & ' : temps moyen :', + & timer_average(jj_nb_caldyn(i),timer_caldyn,i), + & '+-',timer_delta(jj_nb_caldyn(i),timer_caldyn,i) + enddo + + print *,'*********************************' + print *,'****** TIMER VANLEER ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_vanleer(i), + & ' : temps moyen :', + & timer_average(jj_nb_vanleer(i),timer_vanleer,i), + & '+-',timer_delta(jj_nb_vanleer(i),timer_vanleer,i) + enddo + + print *,'*********************************' + print *,'****** TIMER DISSIP ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_dissip(i), + & ' : temps moyen :', + & timer_average(jj_nb_dissip(i),timer_dissip,i), + & '+-',timer_delta(jj_nb_dissip(i),timer_dissip,i) + enddo + +! if (mpi_rank==0) call WriteBands + + endif + + call AdjustBands_caldyn(new_dist) +!$OMP END MASTER +!$OMP BARRIER + CALL leapfrog_switch_caldyn(new_dist) +!$OMP BARRIER + + +!$OMP MASTER + distrib_caldyn=new_dist + CALL set_distrib(distrib_caldyn) +!$OMP END MASTER +!$OMP BARRIER +! call Register_SwapFieldHallo(ucov,ucov,ip1jmp1,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(ucovm1,ucovm1,ip1jmp1,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(vcov,vcov,ip1jm,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(vcovm1,vcovm1,ip1jm,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(teta,teta,ip1jmp1,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(tetam1,tetam1,ip1jmp1,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(masse,masse,ip1jmp1,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(massem1,massem1,ip1jmp1,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(ps,ps,ip1jmp1,1, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(psm1,psm1,ip1jmp1,1, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(pkf,pkf,ip1jmp1,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(pk,pk,ip1jmp1,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(pks,pks,ip1jmp1,1, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(phis,phis,ip1jmp1,1, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(phi,phi,ip1jmp1,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! call Register_SwapFieldHallo(finvmaold,finvmaold,ip1jmp1,llm, +! & jj_Nb_caldyn,0,0,TestRequest) +! +! do j=1,nqtot +! call Register_SwapFieldHallo(q(:,:,j),q(:,:,j),ip1jmp1,llm, +! & jj_nb_caldyn,0,0,TestRequest) +! enddo +! +! call Set_Distrib(distrib_caldyn) +! call SendRequest(TestRequest) +! call WaitRequest(TestRequest) + +!$OMP MASTER + call AdjustBands_dissip(new_dist) +!$OMP END MASTER +!$OMP BARRIER + CALL leapfrog_switch_dissip(new_dist) +!$OMP BARRIER +!$OMP MASTER + distrib_dissip=new_dist +!$OMP END MASTER +!$OMP BARRIER +! call AdjustBands_physic + +c$OMP MASTER + if (mpi_rank==0) call WriteBands +c$OMP END MASTER + + + endif + endif + + + +c----------------------------------------------------------------------- +c calcul des tendances dynamiques: +c -------------------------------- +c$OMP BARRIER +c$OMP MASTER + call VTb(VThallo) +c$OMP END MASTER + + call Register_Hallo_u(ucov,llm,1,1,1,1,TestRequest) + call Register_Hallo_v(vcov,llm,1,1,1,1,TestRequest) + call Register_Hallo_u(teta,llm,1,1,1,1,TestRequest) + call Register_Hallo_u(ps,1,1,2,2,1,TestRequest) + call Register_Hallo_u(pkf,llm,1,1,1,1,TestRequest) + call Register_Hallo_u(pk,llm,1,1,1,1,TestRequest) + call Register_Hallo_u(pks,1,1,1,1,1,TestRequest) + call Register_Hallo_u(p,llmp1,1,1,1,1,TestRequest) + +c do j=1,nqtot +c call Register_Hallo(q(1,1,j),ip1jmp1,llm,1,1,1,1, +c * TestRequest) +c enddo + + call SendRequest(TestRequest) +c$OMP BARRIER + call WaitRequest(TestRequest) + +c$OMP MASTER + call VTe(VThallo) +c$OMP END MASTER +c$OMP BARRIER + + if (debug) then + call WriteField_u('ucov',ucov) + call WriteField_v('vcov',vcov) + call WriteField_u('teta',teta) + call WriteField_u('ps',ps) + call WriteField_u('masse',masse) + call WriteField_u('pk',pk) + call WriteField_u('pks',pks) + call WriteField_u('pkf',pkf) + call WriteField_u('phis',phis) + do j=1,nqtot + call WriteField_u('q'//trim(int2str(j)), + . q(:,:,j)) + enddo + endif + + + True_itau=True_itau+1 + +c$OMP MASTER + PRINT *,"---> itau=",itau," True_itau=",True_itau +c$OMP END MASTER + +c$OMP MASTER + IF (prt_level>9) THEN + WRITE(lunout,*)"leapfrog_p: Iteration No",True_itau + ENDIF + + + call start_timer(timer_caldyn) + + CALL geopot_loc ( ip1jmp1, teta , pk , pks, phis , phi ) + + + call VTb(VTcaldyn) +c$OMP END MASTER +! var_time=time+iday-day_ini + +c$OMP BARRIER +! CALL FTRACE_REGION_BEGIN("caldyn") + time = jD_cur + jH_cur + CALL caldyn_loc + $ ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , + $ phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time ) + +! CALL FTRACE_REGION_END("caldyn") + +c$OMP MASTER + call VTe(VTcaldyn) +c$OMP END MASTER + +#ifdef DEBUG_IO + call WriteField_u('du',du) + call WriteField_v('dv',dv) + call WriteField_u('dteta',dteta) + call WriteField_u('dp',dp) + call WriteField_u('w',w) + call WriteField_u('pbaru',pbaru) + call WriteField_v('pbarv',pbarv) + call WriteField_u('p',p) + call WriteField_u('masse',masse) + call WriteField_u('pk',pk) +#endif +c----------------------------------------------------------------------- +c calcul des tendances advection des traceurs (dont l'humidite) +c ------------------------------------------------------------- + + + IF( forward. OR . leapf ) THEN + + + CALL caladvtrac_loc(q,pbaru,pbarv, + * p, masse, dq, teta, + . flxw,pk, iapptrac) + +! do j=1,nqtot +! call WriteField_u('qadv'//trim(int2str(j)),q(:,:,j)) +! enddo + +c + ENDIF ! of IF( forward. OR . leapf ) + + +c----------------------------------------------------------------------- +c integrations dynamique et traceurs: +c ---------------------------------- + +c$OMP MASTER + call VTb(VTintegre) +c$OMP END MASTER +#ifdef DEBUG_IO + if (true_itau>20) then + call WriteField_u('ucovm1',ucovm1) + call WriteField_v('vcovm1',vcovm1) + call WriteField_u('tetam1',tetam1) + call WriteField_u('psm1',psm1) + call WriteField_u('ucov_int',ucov) + call WriteField_v('vcov_int',vcov) + call WriteField_u('teta_int',teta) + call WriteField_u('ps_int',ps) + endif +#endif +c$OMP BARRIER +! CALL FTRACE_REGION_BEGIN("integrd") + + CALL integrd_loc ( 2,vcovm1,ucovm1,tetam1,psm1,massem1 , + $ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis , + $ finvmaold ) + +! CALL FTRACE_REGION_END("integrd") +c$OMP BARRIER +#ifdef DEBUG_IO + call WriteField_u('ucovm1',ucovm1) + call WriteField_v('vcovm1',vcovm1) + call WriteField_u('tetam1',tetam1) + call WriteField_u('psm1',psm1) + call WriteField_u('ucov_int',ucov) + call WriteField_v('vcov_int',vcov) + call WriteField_u('teta_int',teta) + call WriteField_u('ps_int',ps) +#endif +c do j=1,nqtot +c call WriteField_p('q'//trim(int2str(j)), +c . reshape(q(:,:,j),(/iip1,jmp1,llm/))) +c call WriteField_p('dq'//trim(int2str(j)), +c . reshape(dq(:,:,j),(/iip1,jmp1,llm/))) +c enddo + + +c$OMP MASTER + call VTe(VTintegre) +c$OMP END MASTER +c .P.Le Van (26/04/94 ajout de finvpold dans l'appel d'integrd) +c +c----------------------------------------------------------------------- +c calcul des tendances physiques: +c ------------------------------- +c ######## P.Le Van ( Modif le 6/02/95 ) ########### +c + IF( purmats ) THEN + IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE. + ELSE + IF( itau+1. EQ. itaufin ) lafin = .TRUE. + ENDIF + +cc$OMP END PARALLEL + +c +c + IF( apphys ) THEN + + CALL call_calfis(itau,lafin,clesphy0,ucov,vcov,teta,masse,ps, + & phis,q,flxw) +! #ifdef DEBUG_IO +! call WriteField_u('ucovfi',ucov) +! call WriteField_v('vcovfi',vcov) +! call WriteField_u('tetafi',teta) +! call WriteField_u('pfi',p) +! call WriteField_u('pkfi',pk) +! do j=1,nqtot +! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) +! enddo +! #endif +! c +! c ....... Ajout P.Le Van ( 17/04/96 ) ........... +! c +! cc$OMP PARALLEL DEFAULT(SHARED) +! cc$OMP+ PRIVATE(rdaym_ini,rdayvrai,ijb,ije) + +! c$OMP MASTER +! call suspend_timer(timer_caldyn) + +! write(lunout,*) +! & 'leapfrog_p: Entree dans la physique : Iteration No ',true_itau +! c$OMP END MASTER + +! CALL pression_loc ( ip1jmp1, ap, bp, ps, p ) + +! c$OMP BARRIER +! CALL exner_hyb_loc( ip1jmp1, ps, p,alpha,beta,pks, pk, pkf ) +! c$OMP BARRIER +! jD_cur = jD_ref + day_ini - day_ref +! $ + int (itau * dtvr / daysec) +! jH_cur = jH_ref + & +! & (itau * dtvr / daysec - int(itau * dtvr / daysec)) +! ! call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes) + +! c rajout debug +! c lafin = .true. + + +! c Inbterface avec les routines de phylmd (phymars ... ) +! c ----------------------------------------------------- + +! c+jld + +! c Diagnostique de conservation de l'energie : initialisation +! +! c-jld +! c$OMP BARRIER +! c$OMP MASTER +! call VTb(VThallo) +! c$OMP END MASTER + +! #ifdef DEBUG_IO +! call WriteField_u('ucovfi',ucov) +! call WriteField_v('vcovfi',vcov) +! call WriteField_u('tetafi',teta) +! call WriteField_u('pfi',p) +! call WriteField_u('pkfi',pk) +! #endif +! call SetTag(Request_physic,800) +! +! call Register_SwapField_u(ucov,ucov,distrib_physic, +! * Request_physic,up=2,down=2) +! +! call Register_SwapField_v(vcov,vcov,distrib_physic, +! * Request_physic,up=2,down=2) + +! call Register_SwapField_u(teta,teta,distrib_physic, +! * Request_physic,up=2,down=2) +! +! call Register_SwapField_u(masse,masse,distrib_physic, +! * Request_physic,up=1,down=2) + +! call Register_SwapField_u(p,p,distrib_physic, +! * Request_physic,up=2,down=2) +! +! call Register_SwapField_u(pk,pk,distrib_physic, +! * Request_physic,up=2,down=2) +! +! call Register_SwapField_u(phis,phis,distrib_physic, +! * Request_physic,up=2,down=2) +! +! call Register_SwapField_u(phi,phi,distrib_physic, +! * Request_physic,up=2,down=2) +! +! call Register_SwapField_u(w,w,distrib_physic, +! * Request_physic,up=2,down=2) +! +! call Register_SwapField_u(q,q,distrib_physic, +! * Request_physic,up=2,down=2) + +! call Register_SwapField_u(flxw,flxw,distrib_physic, +! * Request_physic,up=2,down=2) +! +! call SendRequest(Request_Physic) +! c$OMP BARRIER +! call WaitRequest(Request_Physic) + +! c$OMP BARRIER +! c$OMP MASTER +! call Set_Distrib(distrib_Physic) +! call VTe(VThallo) +! +! call VTb(VTphysiq) +! c$OMP END MASTER +! c$OMP BARRIER + +! #ifdef DEBUG_IO +! call WriteField_u('ucovfi',ucov) +! call WriteField_v('vcovfi',vcov) +! call WriteField_u('tetafi',teta) +! call WriteField_u('pfi',p) +! call WriteField_u('pkfi',pk) +! do j=1,nqtot +! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) +! enddo +! #endif +! STOP +! c$OMP BARRIER +! ! CALL FTRACE_REGION_BEGIN("calfis") +! CALL calfis_loc(lafin ,jD_cur, jH_cur, +! $ ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , +! $ du,dv,dteta,dq, +! $ flxw, +! $ clesphy0, dufi,dvfi,dtetafi,dqfi,dpfi ) +! ! CALL FTRACE_REGION_END("calfis") +! ! ijb=ij_begin +! ! ije=ij_end +! ! if ( .not. pole_nord) then +! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) +! ! DO l=1,llm +! ! dufi_tmp(1:iip1,l) = dufi(ijb:ijb+iim,l) +! ! dvfi_tmp(1:iip1,l) = dvfi(ijb:ijb+iim,l) +! ! dtetafi_tmp(1:iip1,l)= dtetafi(ijb:ijb+iim,l) +! ! dqfi_tmp(1:iip1,l,:) = dqfi(ijb:ijb+iim,l,:) +! ! ENDDO +! !c$OMP END DO NOWAIT +! ! +! !c$OMP MASTER +! ! dpfi_tmp(1:iip1) = dpfi(ijb:ijb+iim) +! !c$OMP END MASTER +! ! endif ! of if ( .not. pole_nord) + +! !c$OMP BARRIER +! !c$OMP MASTER +! ! call Set_Distrib(distrib_physic_bis) + +! ! call VTb(VThallo) +! !c$OMP END MASTER +! !c$OMP BARRIER +! ! +! ! call Register_Hallo_u(dufi,llm, +! ! * 1,0,0,1,Request_physic) +! ! +! ! call Register_Hallo_v(dvfi,llm, +! ! * 1,0,0,1,Request_physic) +! ! +! ! call Register_Hallo_u(dtetafi,llm, +! ! * 1,0,0,1,Request_physic) +! ! +! ! call Register_Hallo_u(dpfi,1, +! ! * 1,0,0,1,Request_physic) +! ! +! ! do j=1,nqtot +! ! call Register_Hallo_u(dqfi(ijb_u,1,j),llm, +! ! * 1,0,0,1,Request_physic) +! ! enddo +! ! +! ! call SendRequest(Request_Physic) +! !c$OMP BARRIER +! ! call WaitRequest(Request_Physic) +! ! +! !c$OMP BARRIER +! !c$OMP MASTER +! ! call VTe(VThallo) +! ! +! ! call set_Distrib(distrib_Physic) +! !c$OMP END MASTER +! !c$OMP BARRIER +! ! ijb=ij_begin +! ! if (.not. pole_nord) then +! ! +! !c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) +! ! DO l=1,llm +! ! dufi(ijb:ijb+iim,l) = dufi(ijb:ijb+iim,l)+dufi_tmp(1:iip1,l) +! ! dvfi(ijb:ijb+iim,l) = dvfi(ijb:ijb+iim,l)+dvfi_tmp(1:iip1,l) +! ! dtetafi(ijb:ijb+iim,l) = dtetafi(ijb:ijb+iim,l) +! ! & +dtetafi_tmp(1:iip1,l) +! ! dqfi(ijb:ijb+iim,l,:) = dqfi(ijb:ijb+iim,l,:) +! ! & + dqfi_tmp(1:iip1,l,:) +! ! ENDDO +! !c$OMP END DO NOWAIT +! ! +! !c$OMP MASTER +! ! dpfi(ijb:ijb+iim) = dpfi(ijb:ijb+iim)+ dpfi_tmp(1:iip1) +! !c$OMP END MASTER +! ! +! ! endif ! of if (.not. pole_nord) + +! #ifdef DEBUG_IO +! call WriteField_u('dufi',dufi) +! call WriteField_v('dvfi',dvfi) +! call WriteField_u('dtetafi',dtetafi) +! call WriteField_u('dpfi',dpfi) +! do j=1,nqtot +! call WriteField_u('dqfi'//trim(int2str(j)),dqfi(:,:,j)) +! enddo +! #endif + +! c$OMP BARRIER + +! c ajout des tendances physiques: +! c ------------------------------ +! #ifdef DEBUG_IO +! call WriteField_u('ucovfi',ucov) +! call WriteField_v('vcovfi',vcov) +! call WriteField_u('tetafi',teta) +! call WriteField_u('psfi',ps) +! do j=1,nqtot +! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) +! enddo +! #endif + +! IF (ok_strato) THEN +! CALL top_bound_loc( vcov,ucov,teta,masse,dufi,dvfi,dtetafi) +! ENDIF + +! #ifdef DEBUG_IO +! call WriteField_u('ucovfi',ucov) +! call WriteField_v('vcovfi',vcov) +! call WriteField_u('tetafi',teta) +! call WriteField_u('psfi',ps) +! do j=1,nqtot +! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) +! enddo +! #endif + +! CALL addfi_loc( dtphys, leapf, forward , +! $ ucov, vcov, teta , q ,ps , +! $ dufi, dvfi, dtetafi , dqfi ,dpfi ) + +! #ifdef DEBUG_IO +! call WriteField_u('ucovfi',ucov) +! call WriteField_v('vcovfi',vcov) +! call WriteField_u('tetafi',teta) +! call WriteField_u('psfi',ps) +! do j=1,nqtot +! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) +! enddo +! #endif + +! c$OMP BARRIER +! c$OMP MASTER +! call VTe(VTphysiq) + +! call VTb(VThallo) +! c$OMP END MASTER + +! call SetTag(Request_physic,800) +! call Register_SwapField_u(ucov,ucov, +! * distrib_caldyn,Request_physic) +! +! call Register_SwapField_v(vcov,vcov, +! * distrib_caldyn,Request_physic) +! +! call Register_SwapField_u(teta,teta, +! * distrib_caldyn,Request_physic) +! +! call Register_SwapField_u(masse,masse, +! * distrib_caldyn,Request_physic) + +! call Register_SwapField_u(p,p, +! * distrib_caldyn,Request_physic) +! +! call Register_SwapField_u(pk,pk, +! * distrib_caldyn,Request_physic) +! +! call Register_SwapField_u(phis,phis, +! * distrib_caldyn,Request_physic) +! +! call Register_SwapField_u(phi,phi, +! * distrib_caldyn,Request_physic) +! +! call Register_SwapField_u(w,w, +! * distrib_caldyn,Request_physic) + +! call Register_SwapField_u(q,q, +! * distrib_caldyn,Request_physic) +! +! call SendRequest(Request_Physic) +! c$OMP BARRIER +! call WaitRequest(Request_Physic) + +! c$OMP BARRIER +! c$OMP MASTER +! call VTe(VThallo) +! call set_distrib(distrib_caldyn) +! c$OMP END MASTER +! c$OMP BARRIER +! c +! c Diagnostique de conservation de l'energie : difference +! IF (ip_ebil_dyn.ge.1 ) THEN +! ztit='bil phys' +! CALL diagedyn(ztit,2,1,1,dtphys +! e , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) +! ENDIF + +! #ifdef DEBUG_IO +! call WriteField_u('ucovfi',ucov) +! call WriteField_v('vcovfi',vcov) +! call WriteField_u('tetafi',teta) +! call WriteField_u('psfi',ps) +! do j=1,nqtot +! call WriteField_u('qfi'//trim(int2str(j)),q(:,:,j)) +! enddo +! #endif + + +! c-jld +c$OMP MASTER + if (FirstPhysic) then + ok_start_timer=.TRUE. + FirstPhysic=.false. + endif +c$OMP END MASTER + ENDIF ! of IF( apphys ) + + IF(iflag_phys.EQ.2) THEN ! "Newtonian" case +c Calcul academique de la physique = Rappel Newtonien + fritcion +c -------------------------------------------------------------- +cym teta(:,:)=teta(:,:) +cym s -iphysiq*dtvr*(teta(:,:)-tetarappel(:,:))/taurappel + ijb=ij_begin + ije=ij_end + teta(ijb:ije,:)=teta(ijb:ije,:) + s -iphysiq*dtvr*(teta(ijb:ije,:)-tetarappel(ijb:ije,:))/taurappel + + call Register_Hallo_u(ucov,llm,0,1,1,0,Request_Physic) + call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Physic) + call SendRequest(Request_Physic) +c$OMP BARRIER + call WaitRequest(Request_Physic) + + call friction_loc(ucov,vcov,iphysiq*dtvr) + ENDIF ! of IF(iflag_phys.EQ.2) + + + CALL pression_loc ( ip1jmp1, ap, bp, ps, p ) +c$OMP BARRIER + CALL exner_hyb_loc( ip1jmp1, ps, p,alpha,beta, pks, pk, pkf ) +c$OMP BARRIER + +cc$OMP END PARALLEL + +c----------------------------------------------------------------------- +c dissipation horizontale et verticale des petites echelles: +c ---------------------------------------------------------- + + IF(apdiss) THEN + + CALL call_dissip(ucov,vcov,teta,p,pk,ps) +!cc$OMP PARALLEL DEFAULT(SHARED) +!cc$OMP+ PRIVATE(ijb,ije,tppn,tpn,tpps,tps) +!c$OMP MASTER +! call suspend_timer(timer_caldyn) +! +!c print*,'Entree dans la dissipation : Iteration No ',true_itau +!c calcul de l'energie cinetique avant dissipation +!c print *,'Passage dans la dissipation' + +! call VTb(VThallo) +!c$OMP END MASTER + +!c$OMP BARRIER + +! call Register_SwapField_u(ucov,ucov,distrib_dissip, +! * Request_dissip,up=1,down=1) + +! call Register_SwapField_v(vcov,vcov,distrib_dissip, +! * Request_dissip,up=1,down=1) + +! call Register_SwapField_u(teta,teta,distrib_dissip, +! * Request_dissip) + +! call Register_SwapField_u(p,p,distrib_dissip, +! * Request_dissip) + +! call Register_SwapField_u(pk,pk,distrib_dissip, +! * Request_dissip) + +! call SendRequest(Request_dissip) +!c$OMP BARRIER +! call WaitRequest(Request_dissip) + +!c$OMP BARRIER +!c$OMP MASTER +! call set_distrib(distrib_dissip) +! call VTe(VThallo) +! call VTb(VTdissipation) +! call start_timer(timer_dissip) +!c$OMP END MASTER +!c$OMP BARRIER + +! call covcont_loc(llm,ucov,vcov,ucont,vcont) +! call enercin_loc(vcov,ucov,vcont,ucont,ecin0) + +!c dissipation + +!! CALL FTRACE_REGION_BEGIN("dissip") +! CALL dissip_loc(vcov,ucov,teta,p,dvdis,dudis,dtetadis) + +!#ifdef DEBUG_IO +! call WriteField_u('dudis',dudis) +! call WriteField_v('dvdis',dvdis) +! call WriteField_u('dtetadis',dtetadis) +!#endif +! +!! CALL FTRACE_REGION_END("dissip") +! +! ijb=ij_begin +! ije=ij_end +!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) +! DO l=1,llm +! ucov(ijb:ije,l)=ucov(ijb:ije,l)+dudis(ijb:ije,l) +! ENDDO +!c$OMP END DO NOWAIT +! if (pole_sud) ije=ije-iip1 +!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) +! DO l=1,llm +! vcov(ijb:ije,l)=vcov(ijb:ije,l)+dvdis(ijb:ije,l) +! ENDDO +!c$OMP END DO NOWAIT + +!c teta=teta+dtetadis + + +!c------------------------------------------------------------------------ +! if (dissip_conservative) then +!C On rajoute la tendance due a la transform. Ec -> E therm. cree +!C lors de la dissipation +!c$OMP BARRIER +!c$OMP MASTER +! call suspend_timer(timer_dissip) +! call VTb(VThallo) +!c$OMP END MASTER +! call Register_Hallo_u(ucov,llm,1,1,1,1,Request_Dissip) +! call Register_Hallo_v(vcov,llm,1,1,1,1,Request_Dissip) +! call SendRequest(Request_Dissip) +!c$OMP BARRIER +! call WaitRequest(Request_Dissip) +!c$OMP MASTER +! call VTe(VThallo) +! call resume_timer(timer_dissip) +!c$OMP END MASTER +!c$OMP BARRIER +! call covcont_loc(llm,ucov,vcov,ucont,vcont) +! call enercin_loc(vcov,ucov,vcont,ucont,ecin) +! +! ijb=ij_begin +! ije=ij_end +!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) +! do l=1,llm +! do ij=ijb,ije +! dtetaecdt(ij,l)= (ecin0(ij,l)-ecin(ij,l))/ pk(ij,l) +! dtetadis(ij,l)=dtetadis(ij,l)+dtetaecdt(ij,l) +! enddo +! enddo +!c$OMP END DO NOWAIT +! endif + +! ijb=ij_begin +! ije=ij_end +!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) +! do l=1,llm +! do ij=ijb,ije +! teta(ij,l)=teta(ij,l)+dtetadis(ij,l) +! enddo +! enddo +!c$OMP END DO NOWAIT +!c------------------------------------------------------------------------ + + +!c ....... P. Le Van ( ajout le 17/04/96 ) ........... +!c ... Calcul de la valeur moyenne, unique de h aux poles ..... +!c + +! ijb=ij_begin +! ije=ij_end +! +! if (pole_nord) then +!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) +! DO l = 1, llm +! DO ij = 1,iim +! tppn(ij) = aire( ij ) * teta( ij ,l) +! ENDDO +! tpn = SSUM(iim,tppn,1)/apoln + +! DO ij = 1, iip1 +! teta( ij ,l) = tpn +! ENDDO +! ENDDO +!c$OMP END DO NOWAIT + +!c$OMP MASTER +! DO ij = 1,iim +! tppn(ij) = aire( ij ) * ps ( ij ) +! ENDDO +! tpn = SSUM(iim,tppn,1)/apoln +! +! DO ij = 1, iip1 +! ps( ij ) = tpn +! ENDDO +!c$OMP END MASTER +! endif +! +! if (pole_sud) then +!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) +! DO l = 1, llm +! DO ij = 1,iim +! tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) +! ENDDO +! tps = SSUM(iim,tpps,1)/apols + +! DO ij = 1, iip1 +! teta(ij+ip1jm,l) = tps +! ENDDO +! ENDDO +!c$OMP END DO NOWAIT + +!c$OMP MASTER +! DO ij = 1,iim +! tpps(ij) = aire(ij+ip1jm) * ps (ij+ip1jm) +! ENDDO +! tps = SSUM(iim,tpps,1)/apols +! +! DO ij = 1, iip1 +! ps(ij+ip1jm) = tps +! ENDDO +!c$OMP END MASTER +! endif + + +!c$OMP BARRIER +!c$OMP MASTER +! call VTe(VTdissipation) + +! call stop_timer(timer_dissip) +! +! call VTb(VThallo) +!c$OMP END MASTER +! call Register_SwapField_u(ucov,ucov,distrib_caldyn, +! * Request_dissip) + +! call Register_SwapField_v(vcov,vcov,distrib_caldyn, +! * Request_dissip) + +! call Register_SwapField_u(teta,teta,distrib_caldyn, +! * Request_dissip) + +! call Register_SwapField_u(p,p,distrib_caldyn, +! * Request_dissip) + +! call Register_SwapField_u(pk,pk,distrib_caldyn, +! * Request_dissip) + +! call SendRequest(Request_dissip) +!c$OMP BARRIER +! call WaitRequest(Request_dissip) + +!c$OMP BARRIER +!c$OMP MASTER +! call set_distrib(distrib_caldyn) +! call VTe(VThallo) +! call resume_timer(timer_caldyn) +!c print *,'fin dissipation' +!c$OMP END MASTER +!c$OMP BARRIER + END IF + +cc$OMP END PARALLEL + +c ajout debug +c IF( lafin ) then +c abort_message = 'Simulation finished' +c call abort_gcm(modname,abort_message,0) +c ENDIF + +c ******************************************************************** +c ******************************************************************** +c .... fin de l'integration dynamique et physique pour le pas itau .. +c ******************************************************************** +c ******************************************************************** + +c preparation du pas d'integration suivant ...... +cym call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/))) +cym call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/))) +c$OMP MASTER + call stop_timer(timer_caldyn) +c$OMP END MASTER + IF (itau==itaumax) then +c$OMP MASTER + call allgather_timer_average + + if (mpi_rank==0) then + + print *,'*********************************' + print *,'****** TIMER CALDYN ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_caldyn(i), + & ' : temps moyen :', + & timer_average(jj_nb_caldyn(i),timer_caldyn,i) + enddo + + print *,'*********************************' + print *,'****** TIMER VANLEER ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_vanleer(i), + & ' : temps moyen :', + & timer_average(jj_nb_vanleer(i),timer_vanleer,i) + enddo + + print *,'*********************************' + print *,'****** TIMER DISSIP ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_dissip(i), + & ' : temps moyen :', + & timer_average(jj_nb_dissip(i),timer_dissip,i) + enddo + + print *,'*********************************' + print *,'****** TIMER PHYSIC ******' + do i=0,mpi_size-1 + print *,'proc',i,' : Nb Bandes :',jj_nb_physic(i), + & ' : temps moyen :', + & timer_average(jj_nb_physic(i),timer_physic,i) + enddo + + endif + + print *,'Taille du Buffer MPI (REAL*8)',MaxBufferSize + print *,'Taille du Buffer MPI utilise (REAL*8)',MaxBufferSize_Used + print *, 'Temps total ecoule sur la parallelisation :',DiffTime() + print *, 'Temps CPU ecoule sur la parallelisation :',DiffCpuTime() + CALL print_filtre_timer +c$OMP END MASTER + CALL dynredem1_loc("restart.nc",0.0, + . vcov,ucov,teta,q,masse,ps) +c$OMP MASTER + call fin_getparam + call finalize_parallel +c$OMP END MASTER +c$OMP BARRIER + RETURN + ENDIF + + IF ( .NOT.purmats ) THEN +c ........................................................ +c .............. schema matsuno + leapfrog .............. +c ........................................................ + + IF(forward. OR. leapf) THEN + itau= itau + 1 +! iday= day_ini+itau/day_step +! time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 +! IF(time.GT.1.) THEN +! time = time-1. +! iday = iday+1 +! ENDIF + ENDIF + + + IF( itau. EQ. itaufinp1 ) then + + if (flag_verif) then + write(79,*) 'ucov',ucov + write(80,*) 'vcov',vcov + write(81,*) 'teta',teta + write(82,*) 'ps',ps + write(83,*) 'q',q + WRITE(85,*) 'q1 = ',q(:,:,1) + WRITE(86,*) 'q3 = ',q(:,:,3) + endif + + +c$OMP MASTER + call fin_getparam + call finalize_parallel +c$OMP END MASTER + abort_message = 'Simulation finished' + call abort_gcm(modname,abort_message,0) + RETURN + ENDIF +c----------------------------------------------------------------------- +c ecriture du fichier histoire moyenne: +c ------------------------------------- + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN +c$OMP BARRIER + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF + +#ifdef CPP_IOIPSL + IF (ok_dynzon) THEN + + CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav, + , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) + + ENDIF !ok_dynzon + + IF (ok_dyn_ave) THEN + CALL writedynav_loc(itau,vcov, + & ucov,teta,pk,phi,q,masse,ps,phis) + ENDIF +#endif + ENDIF + +c----------------------------------------------------------------------- +c ecriture de la bande histoire: +c ------------------------------ + + IF( MOD(itau,iecri).EQ.0) THEN + ! Ehouarn: output only during LF or Backward Matsuno + if (leapf.or.(.not.leapf.and.(.not.forward))) then + +c$OMP BARRIER +c$OMP MASTER + CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi) +c$OMP END MASTER +c$OMP BARRIER + +#ifdef CPP_IOIPSL + if (ok_dyn_ins) then + CALL writehist_loc(itau,vcov,ucov,teta,phi,q, + & masse,ps,phis) + endif +#endif + endif ! of if (leapf.or.(.not.leapf.and.(.not.forward))) + ENDIF ! of IF(MOD(itau,iecri).EQ.0) + + IF(itau.EQ.itaufin) THEN + +c$OMP BARRIER + + if (planet_type.eq."earth") then +! Write an Earth-format restart file + CALL dynredem1_loc("restart.nc",0.0, + & vcov,ucov,teta,q,masse,ps) + endif ! of if (planet_type.eq."earth") + +! CLOSE(99) + ENDIF ! of IF (itau.EQ.itaufin) + +c----------------------------------------------------------------------- +c gestion de l'integration temporelle: +c ------------------------------------ + + IF( MOD(itau,iperiod).EQ.0 ) THEN + GO TO 1 + ELSE IF ( MOD(itau-1,iperiod). EQ. 0 ) THEN + + IF( forward ) THEN +c fin du pas forward et debut du pas backward + + forward = .FALSE. + leapf = .FALSE. + GO TO 2 + + ELSE +c fin du pas backward et debut du premier pas leapfrog + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF + ELSE + +c ...... pas leapfrog ..... + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF ! of IF (MOD(itau,iperiod).EQ.0) + ! ELSEIF (MOD(itau-1,iperiod).EQ.0) + + + ELSE ! of IF (.not.purmats) + +c ........................................................ +c .............. schema matsuno ............... +c ........................................................ + IF( forward ) THEN + + itau = itau + 1 +! iday = day_ini+itau/day_step +! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 +! +! IF(time.GT.1.) THEN +! time = time-1. +! iday = iday+1 +! ENDIF + + forward = .FALSE. + IF( itau. EQ. itaufinp1 ) then +c$OMP MASTER + call fin_getparam + call finalize_parallel +c$OMP END MASTER + abort_message = 'Simulation finished' + call abort_gcm(modname,abort_message,0) + RETURN + ENDIF + GO TO 2 + + ELSE ! of IF(forward) i.e. backward step + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF + +#ifdef CPP_IOIPSL + IF (ok_dynzon) THEN + CALL bilan_dyn_loc(2,dtvr*iperiod,dtvr*day_step*periodav, + , ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) + ENDIF + + IF (ok_dyn_ave) THEN + CALL writedynav_loc(itau,vcov, + & ucov,teta,pk,phi,q,masse,ps,phis) + ENDIF +#endif + ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) + + + IF(MOD(itau,iecri ).EQ.0) THEN + +c$OMP BARRIER +c$OMP MASTER + CALL geopot_loc(ip1jmp1,teta,pk,pks,phis,phi) +c$OMP END MASTER +c$OMP BARRIER + + +#ifdef CPP_IOIPSL + if (ok_dyn_ins) then + CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis) + endif ! of if (ok_dyn_ins) +#endif + ENDIF ! of IF(MOD(itau,iecri).EQ.0) + + + IF(itau.EQ.itaufin) THEN + if (planet_type.eq."earth") then + CALL dynredem1_loc("restart.nc",0.0, + . vcov,ucov,teta,q,masse,ps) + endif ! of if (planet_type.eq."earth") + ENDIF ! of IF(itau.EQ.itaufin) + + forward = .TRUE. + GO TO 1 + + ENDIF ! of IF (forward) + + END IF ! of IF(.not.purmats) +c$OMP MASTER + call fin_getparam + call finalize_parallel +c$OMP END MASTER + abort_message = 'Simulation finished' + call abort_gcm(modname,abort_message,0) + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/leapfrog_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/leapfrog_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/leapfrog_mod.F90 (revision 1632) @@ -0,0 +1,163 @@ +MODULE leapfrog_mod + + REAL,POINTER,SAVE :: ucov(:,:) + REAL,POINTER,SAVE :: vcov(:,:) + REAL,POINTER,SAVE :: teta(:,:) + REAL,POINTER,SAVE :: ps(:) + REAL,POINTER,SAVE :: masse(:,:) + REAL,POINTER,SAVE :: phis(:) + REAL,POINTER,SAVE :: q(:,:,:) + REAL,POINTER,SAVE :: p(:,:) + REAL,POINTER,SAVE :: pks(:) + REAL,POINTER,SAVE :: pk(:,:) + REAL,POINTER,SAVE :: pkf(:,:) + REAL,POINTER,SAVE :: phi(:,:) + REAL,POINTER,SAVE :: w(:,:) + REAL,POINTER,SAVE :: pbaru(:,:) + REAL,POINTER,SAVE :: pbarv(:,:) + REAL,POINTER,SAVE :: vcovm1(:,:) + REAL,POINTER,SAVE :: ucovm1(:,:) + REAL,POINTER,SAVE :: tetam1(:,:) + REAL,POINTER,SAVE :: psm1(:) + REAL,POINTER,SAVE :: massem1(:,:) + REAL,POINTER,SAVE :: dv(:,:) + REAL,POINTER,SAVE :: du(:,:) + REAL,POINTER,SAVE :: dteta(:,:) + REAL,POINTER,SAVE :: dp(:) + REAL,POINTER,SAVE :: dq(:,:,:) + REAL,POINTER,SAVE :: finvmaold(:,:) + REAL,POINTER,SAVE :: alpha(:,:) + REAL,POINTER,SAVE :: beta(:,:) + REAL,POINTER,SAVE :: flxw(:,:) + REAL,POINTER,SAVE :: unat(:,:) + REAL,POINTER,SAVE :: vnat(:,:) + + + +CONTAINS + + SUBROUTINE leapfrog_allocate + USE bands + USE allocate_field + USE parallel + USE dimensions + USE infotrac + USE caldyn_mod,ONLY : caldyn_allocate + USE integrd_mod,ONLY : integrd_allocate + USE caladvtrac_mod,ONLY : caladvtrac_allocate + USE call_calfis_mod,ONLY : call_calfis_allocate + USE call_dissip_mod, ONLY : call_dissip_allocate + IMPLICIT NONE + TYPE(distrib),POINTER :: d + + + d=>distrib_caldyn + CALL allocate_u(ucov,llm,d) + CALL allocate_v(vcov,llm,d) + CALL allocate_u(teta,llm,d) + CALL allocate_u(ps,d) + CALL allocate_u(masse,llm,d) + CALL allocate_u(phis,d) + CALL allocate_u(q,llm,nqtot,d) + CALL allocate_u(p,llmp1,d) + CALL allocate_u(pks,d) + CALL allocate_u(pk,llm,d) + CALL allocate_u(pkf,llm,d) + CALL allocate_u(phi,llm,d) + CALL allocate_u(w,llm,d) + CALL allocate_u(pbaru,llm,d) + CALL allocate_v(pbarv,llm,d) + CALL allocate_v(vcovm1,llm,d) + CALL allocate_u(ucovm1,llm,d) + CALL allocate_u(tetam1,llm,d) + CALL allocate_u(psm1,d) + CALL allocate_u(massem1,llm,d) + CALL allocate_v(dv,llm,d) + CALL allocate_u(du,llm,d) + CALL allocate_u(dteta,llm,d) + CALL allocate_u(dp,d) + CALL allocate_u(dq,llm,nqtot,d) + CALL allocate_u(finvmaold,llm,d) + CALL allocate_u(alpha,llm,d) + CALL allocate_u(beta,llm,d) + CALL allocate_u(flxw,llm,d) + CALL allocate_u(unat,llm,d) + CALL allocate_v(vnat,llm,d) + + CALL caldyn_allocate + CALL integrd_allocate + CALL caladvtrac_allocate + CALL call_calfis_allocate + CALL call_dissip_allocate + + END SUBROUTINE leapfrog_allocate + + SUBROUTINE leapfrog_switch_caldyn(dist) + USE allocate_field + USE bands + USE parallel + USE caldyn_mod,ONLY : caldyn_switch_caldyn + USE integrd_mod,ONLY : integrd_switch_caldyn + USE caladvtrac_mod,ONLY : caladvtrac_switch_caldyn + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(ucov,distrib_caldyn,dist) + CALL switch_v(vcov,distrib_caldyn,dist) + CALL switch_u(teta,distrib_caldyn,dist) + CALL switch_u(ps,distrib_caldyn,dist) + CALL switch_u(masse,distrib_caldyn,dist) + CALL switch_u(phis,distrib_caldyn,dist,up=halo_max,down=halo_max) + CALL switch_u(q,distrib_caldyn,dist) + CALL switch_u(p,distrib_caldyn,dist) + CALL switch_u(pks,distrib_caldyn,dist) + CALL switch_u(pk,distrib_caldyn,dist) + CALL switch_u(pkf,distrib_caldyn,dist) + CALL switch_u(phi,distrib_caldyn,dist) + CALL switch_u(w,distrib_caldyn,dist) + CALL switch_u(pbaru,distrib_caldyn,dist) + CALL switch_v(pbarv,distrib_caldyn,dist) + CALL switch_v(vcovm1,distrib_caldyn,dist) + CALL switch_u(ucovm1,distrib_caldyn,dist) + CALL switch_u(tetam1,distrib_caldyn,dist) + CALL switch_u(psm1,distrib_caldyn,dist) + CALL switch_u(massem1,distrib_caldyn,dist) + CALL switch_v(dv,distrib_caldyn,dist) + CALL switch_u(du,distrib_caldyn,dist) + CALL switch_u(dteta,distrib_caldyn,dist) + CALL switch_u(dp,distrib_caldyn,dist) + CALL switch_u(dq,distrib_caldyn,dist) + CALL switch_u(finvmaold,distrib_caldyn,dist) + CALL switch_u(alpha,distrib_caldyn,dist) + CALL switch_u(beta,distrib_caldyn,dist) + CALL switch_u(flxw,distrib_caldyn,dist) + CALL switch_u(unat,distrib_caldyn,dist) + CALL switch_v(vnat,distrib_caldyn,dist) + + + CALL caldyn_switch_caldyn(dist) + CALL integrd_switch_caldyn(dist) + CALL caladvtrac_switch_caldyn(dist) + + END SUBROUTINE leapfrog_switch_caldyn + + SUBROUTINE leapfrog_switch_dissip(dist) + USE allocate_field + USE bands + USE parallel + USE call_dissip_mod,ONLY : call_dissip_switch_dissip + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL call_dissip_switch_dissip(dist) + + END SUBROUTINE leapfrog_switch_dissip + +END MODULE leapfrog_mod + + + + + + + Index: /LMDZ5/trunk/libf/dyn3dmem/limit_netcdf.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/limit_netcdf.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/limit_netcdf.F (revision 1632) @@ -0,0 +1,1332 @@ +! +! $Id: limit_netcdf.F 1299 2010-01-20 14:27:21Z fairhead $ +! +C +C + SUBROUTINE limit_netcdf(interbar, extrap, oldice, masque) +#ifdef CPP_EARTH +! This routine is designed to work for Earth + USE dimphy + USE control_mod + use phys_state_var_mod , ONLY : pctsrf + use inter_barxy_m, only: inter_barxy + + IMPLICIT none +c +c------------------------------------------------------------- +C Author : L. Fairhead +C Date : 27/01/94 +C Objet : Construction des fichiers de conditions aux limites +C pour le nouveau +C modele a partir de fichiers de climatologie. Les deux +C grilles doivent etre regulieres +c +c Modifie par z.x.li (le23mars1994) +c Modifie par L. Fairhead (fairhead@lmd.jussieu.fr) septembre 1999 +c pour lecture netcdf dans LMDZ.3.3 +c Modifie par P;Le Van , juillet 2001 +c------------------------------------------------------------- +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "netcdf.inc" +#include "comvert.h" +#include "comgeom2.h" +#include "comconst.h" +cy#include "dimphy.h" +#include "indicesol.h" +#include "iniprint.h" +c +c----------------------------------------------------------------------- + LOGICAL interbar, extrap, oldice + + REAL phy_nat(klon,360), phy_nat0(klon) + REAL phy_alb(klon,360) + REAL phy_sst(klon,360) + REAL phy_bil(klon,360) + REAL phy_rug(klon,360) + REAL phy_ice(klon) +c + real pctsrf_t(klon,nbsrf,360) + + REAL verif + + REAL masque(iip1,jjp1) + REAL mask(iim,jjp1) +CPB +C newlmt indique l'utilisation de la sous-maille fractionnelle +C tandis que l'ancien codage utilise l'indicateur du sol (0,1,2,3) + LOGICAL newlmt, fracterre + PARAMETER(newlmt=.TRUE.) + PARAMETER(fracterre = .TRUE.) + +C Declarations pour le champ de depart + INTEGER imdep, jmdep,lmdep + INTEGER tbid + PARAMETER ( tbid = 60 ) ! >52 semaines + REAL timecoord(tbid) +c + REAL , ALLOCATABLE :: dlon_msk(:), dlat_msk(:) + REAL , ALLOCATABLE :: lonmsk_ini(:), latmsk_ini(:) + REAL , ALLOCATABLE :: dlon(:), dlat(:) + REAL , ALLOCATABLE :: dlon_ini(:), dlat_ini(:) + REAL , ALLOCATABLE :: champ_msk(:), champ(:, :) + REAL , ALLOCATABLE :: work(:,:) + + CHARACTER*25 title + +C Declarations pour le champ interpole 2D + REAL champint(iim,jjp1) + real chmin,chmax + +C Declarations pour le champ interpole 3D + REAL champtime(iim,jjp1,tbid) + REAL timeyear(tbid) + REAL champan(iip1,jjp1,366) + +C Declarations pour l'inteprolation verticale + REAL ax(tbid), ay(tbid) + REAL by + REAL yder(tbid) + + + INTEGER ierr + INTEGER dimfirst(3) + INTEGER dimlast(3) +c + INTEGER nid, ndim, ntim + INTEGER dims(2), debut(2), epais(2) + INTEGER id_tim + INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB +CPB + INTEGER id_FOCE, id_FSIC, id_FTER, id_FLIC + + INTEGER i, j, k, l, ji +c declarations pour lecture glace de mer + INTEGER :: iml_lic, jml_lic, llm_tmp, ttm_tmp, iret + INTEGER :: itaul(1), fid + REAL :: lev(1), date, dt + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_lic, lat_lic + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_lic, dlat_lic + REAL, ALLOCATABLE, DIMENSION (:,:) :: fraclic + REAL :: flic_tmp(iip1, jjp1) + +c Diverses variables locales + REAL time +! pour la lecture du fichier masque ocean + integer :: nid_o2a + logical :: couple = .false. + INTEGER :: iml_omask, jml_omask + REAL, ALLOCATABLE, DIMENSION(:,:) :: lon_omask, lat_omask + REAL, ALLOCATABLE, DIMENSION(:) :: dlon_omask, dlat_omask + REAL, ALLOCATABLE, DIMENSION (:,:) :: ocemask, ocetmp + real, dimension(klon) :: ocemask_fi + + INTEGER longcles + PARAMETER ( longcles = 20 ) + REAL clesphy0 ( longcles ) +#include "serre.h" + INTEGER ncid,varid,ndimid(4),dimid + character*30 namedim + CHARACTER*80 :: varname + +cIM28/02/2002 <== PM + REAL tmidmonth(12) + SAVE tmidmonth + DATA tmidmonth/15,45,75,105,135,165,195,225,255,285,315,345/ + +c initialisations: + CALL conf_gcm( 99, .TRUE. , clesphy0 ) + + + pi = 4. * ATAN(1.) + rad = 6 371 229. + omeg = 4.* ASIN(1.)/(24.*3600.) + g = 9.8 + daysec = 86400. + kappa = 0.2857143 + cpp = 1004.70885 + dtvr = daysec/ REAL(day_step) + CALL inigeom +c +C Traitement du relief au sol +c + write(*,*) 'Traitement du relief au sol pour fabriquer masque' + ierr = NF_OPEN('Relief.nc', NF_NOWRITE, ncid) + + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ierr = NF_INQ_VARID(ncid,'RELIEF',varid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( lonmsk_ini(imdep) ) + ALLOCATE( dlon_msk(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,lonmsk_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,lonmsk_ini) +#endif + +c + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( latmsk_ini(jmdep) ) + ALLOCATE( dlat_msk(jmdep) ) + ALLOCATE( champ_msk(imdep*jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,latmsk_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,latmsk_ini) +#endif +c + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,varid,champ_msk) +#else + ierr = NF_GET_VAR_REAL(ncid,varid,champ_msk) +#endif +c + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + title='RELIEF' + + CALL conf_dat2d(title,imdep, jmdep, lonmsk_ini, latmsk_ini, + . dlon_msk, dlat_msk, champ_msk, interbar ) + + DO i = 1, iim + DO j = 1, jjp1 + mask(i,j) = masque(i,j) + ENDDO + ENDDO + WRITE(*,*) 'MASK:' + WRITE(*,'(96i1)')INT(mask) + ierr = NF_CLOSE(ncid) +c +c +C Traitement de la rugosite +c + PRINT*, 'Traitement de la rugosite' + ierr = NF_OPEN('Rugos.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ierr = NF_INQ_VARID(ncid,'RUGOS',varid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlon_ini(imdep) ) + ALLOCATE( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlat_ini(jmdep) ) + ALLOCATE( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', lmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + ALLOCATE( champ(imdep, jmdep) ) + + DO 200 l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) + print*,dimfirst,dimlast +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title = 'Rugosite Amip ' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) + + IF ( interbar ) THEN + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour la rugosite $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF + CALL inter_barxy(dlon, dlat(:jmdep -1), log(champ), rlonu(:iim), + $ rlatv, champint) + DO j=1,jjp1 + DO i=1,iim + champint(i,j)=EXP(champint(i,j)) + ENDDO + ENDDO + + DO j = 1, jjp1 + DO i = 1, iim + IF(NINT(mask(i,j)).NE.1) THEN + champint( i,j ) = 0.001 + ENDIF + ENDDO + ENDDO + ELSE + CALL rugosite(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint, mask) + ENDIF + DO j = 1,jjp1 + DO i = 1, iim + champtime (i,j,l) = champint(i,j) + ENDDO + ENDDO +200 CONTINUE +c + DO l = 1, lmdep + timeyear(l) = timecoord(l) + ENDDO + + PRINT 222, timeyear(:lmdep) +222 FORMAT(2x,' Time year ',10f6.1) +c + + PRINT*, 'Interpolation temporelle dans l annee' + + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i,j,l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = REAL(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1,j,k) = champan(1,j,k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' Rugosite au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c + DO k = 1, 360 + CALL gr_dyn_fi(1,iip1,jjp1,klon,champan(1,1,k), phy_rug(1,k)) + ENDDO +c + ierr = NF_CLOSE(ncid) + + DEALLOCATE( dlon ) + DEALLOCATE( dlon_ini ) + DEALLOCATE( dlat ) + DEALLOCATE( dlat_ini ) + DEALLOCATE( champ ) +c +c +C Traitement de la glace oceanique +c + PRINT*, 'Traitement de la glace oceanique' + + ierr = NF_OPEN('amipbc_sic_1x1.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + ierr = NF_OPEN('amipbc_sic_1x1_clim.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + print *, NF_STRERROR(ierr) + STOP + endif + ENDIF + +cIM22/02/2002 +cIM07/03/2002 AMIP.nc & amip79to95.nc +cIM ierr = NF_INQ_VARID(ncid,'SEA_ICE',varid) +cIM07/03/2002 amipbc_sic_1x1_clim.nc & amipbc_sic_1x1.nc + ierr = NF_INQ_VARID(ncid,'sicbcs',varid) +cIM22/02/2002 + if (ierr.ne.0) then + print *, NF_STRERROR(ierr),'sicbcs' + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlon_ini(imdep) ) + ALLOCATE ( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlat_ini(jmdep) ) + ALLOCATE ( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, lmdep +cIM28/02/2002 +cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours +c Ici on suppose qu'on a 12 mois (de 30 jours). + IF (lmdep.NE.12) THEN + print *, 'Unknown AMIP file: not 12 months ?' + STOP + ENDIF +cIM28/02/2002 + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + ALLOCATE ( champ(imdep, jmdep) ) + + DO l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title = 'Sea-ice Amip ' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) +c + IF( oldice ) THEN + CALL sea_ice(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ELSEIF ( interbar ) THEN + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour Sea-ice Amip $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF +cIM07/03/2002 +cIM22/02/2002 : Sea-ice Amip entre 0. et 1. +cIM PRINT*,'SUB. limit_netcdf.F IM : Sea-ice et SST Amip_new clim' +cIM DO j = 1, imdep * jmdep +cIM28/02/2002 <==PM champ(j) = champ(j)/100. +cIM14/03/2002 champ(j) = max(0.0,(min(1.0, (champ(j)/100.) ))) +cIM champ(j) = amax1(0.0,(amin1(1.0, (champ(j)/100.) ))) +cIM ENDDO +cIM22/02/2002 + CALL inter_barxy (dlon, dlat(:jmdep -1), champ, rlonu(:iim), + $ rlatv, champint) + ELSE + CALL sea_ice(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ENDIF + DO j = 1,jjp1 + DO i = 1, iim + champtime (i,j,l) = champint(i,j) + ENDDO + ENDDO + ENDDO +c + DO l = 1, lmdep +cIM28/02/2002 <== PM timeyear(l) = timecoord(l) +cIM timeyear(l) = timecoord(l) +cIM07/03/2002 + timeyear(l) = tmidmonth(l) + ENDDO + PRINT 222, timeyear(:lmdep) +c + PRINT*, 'Interpolation temporelle' + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i,j,l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = REAL(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1, j, k) = champan(1, j, k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' Sea ice au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c +cIM14/03/2002 : Sea-ice Amip entre 0. et 1. + PRINT*,'SUB. limit_netcdf.F IM : Sea-ice Amipbc ' + DO k = 1, 360 + DO j = 1, jjp1 + DO i = 1, iim + champan(i, j, k) = + $ amax1(0.0,(amin1(1.0,(champan(i, j, k)/100.)))) + ENDDO + champan(iip1, j, k) = champan(1, j, k) + ENDDO + ENDDO +cIM14/03/2002 + + DO k = 1, 360 + CALL gr_dyn_fi(1, iip1, jjp1, klon, + . champan(1,1,k), phy_ice) + IF ( newlmt) THEN + +CPB en attendant de mettre fraction de terre +c + WHERE(phy_ice(1:klon) .GE. 1.) phy_ice(1 : klon) = 1. + WHERE(phy_ice(1:klon) .LT. EPSFRA) phy_ice(1 : klon) = 0. +c + IF (fracterre ) THEN +c WRITE(*,*) 'passe dans cas fracterre' + pctsrf_t(:,is_ter,k) = pctsrf(:,is_ter) + pctsrf_t(:,is_lic,k) = pctsrf(:,is_lic) + pctsrf_t(1:klon,is_sic,k) = phy_ice(1:klon) + $ - pctsrf_t(1:klon,is_lic,k) +c Il y a des cas ou il y a de la glace dans landiceref et pas dans AMIP + WHERE (pctsrf_t(1:klon,is_sic,k) .LE. 0) + pctsrf_t(1:klon,is_sic,k) = 0. + END WHERE + WHERE( 1. - zmasq(1:klon) .LT. EPSFRA) + pctsrf_t(1:klon,is_sic,k) = 0. + pctsrf_t(1:klon,is_oce,k) = 0. + END WHERE + DO i = 1, klon + IF ( 1. - zmasq(i) .GT. EPSFRA) THEN + IF ( pctsrf_t(i,is_sic,k) .GE. 1 - zmasq(i)) THEN + pctsrf_t(i,is_sic,k) = 1 - zmasq(i) + pctsrf_t(i,is_oce,k) = 0. + ELSE + pctsrf_t(i,is_oce,k) = 1 - zmasq(i) + $ - pctsrf_t(i,is_sic,k) + IF (pctsrf_t(i,is_oce,k) .LT. EPSFRA) THEN + pctsrf_t(i,is_oce,k) = 0. + pctsrf_t(i,is_sic,k) = 1 - zmasq(i) + ENDIF + ENDIF + ENDIF + if (pctsrf_t(i,is_oce,k) .lt. 0.) then + WRITE(*,*) 'pb sous maille au point : i,k ' + $ , i,k,pctsrf_t(:,is_oce,k) + ENDIF + IF ( abs( pctsrf_t(i, is_ter,k) + pctsrf_t(i, is_lic,k) + + $ pctsrf_t(i, is_oce,k) + pctsrf_t(i, is_sic,k) - 1.) + $ .GT. EPSFRA) THEN + WRITE(*,*) 'physiq : pb sous surface au point ', i, + $ pctsrf_t(i, 1 : nbsrf,k), phy_ice(i) + ENDIF + END DO + ELSE + DO i = 1, klon + pctsrf_t(i,is_ter,k) = pctsrf(i,is_ter) + IF (NINT(pctsrf(i,is_ter)).EQ.1 ) THEN + pctsrf_t(i,is_sic,k) = 0. + pctsrf_t(i,is_oce,k) = 0. + IF(phy_ice(i) .GE. 1.e-5) THEN + pctsrf_t(i,is_lic,k) = phy_ice(i) + pctsrf_t(i,is_ter,k) = pctsrf_t(i,is_ter,k) + . - pctsrf_t(i,is_lic,k) + ELSE + pctsrf_t(i,is_lic,k) = 0. + ENDIF + ELSE + pctsrf_t(i,is_lic,k) = 0. + IF(phy_ice(i) .GE. 1.e-5) THEN + pctsrf_t(i,is_ter,k) = 0. + pctsrf_t(i,is_sic,k) = phy_ice(i) + pctsrf_t(i,is_oce,k) = 1. - pctsrf_t(i,is_sic,k) + ELSE + pctsrf_t(i,is_sic,k) = 0. + pctsrf_t(i,is_oce,k) = 1. + ENDIF + ENDIF + verif = pctsrf_t(i,is_ter,k) + + . pctsrf_t(i,is_oce,k) + + . pctsrf_t(i,is_sic,k) + + . pctsrf_t(i,is_lic,k) + IF ( verif .LT. 1. - 1.e-5 .OR. + $ verif .GT. 1 + 1.e-5) THEN + WRITE(*,*) 'pb sous maille au point : i,k,verif ' + $ , i,k,verif + ENDIF + END DO + ENDIF + ELSE + DO i = 1, klon + phy_nat(i,k) = phy_nat0(i) + IF ( (phy_ice(i) - 0.5).GE.1.e-5 ) THEN + IF (NINT(phy_nat0(i)).EQ.0) THEN + phy_nat(i,k) = 3.0 + ELSE + phy_nat(i,k) = 2.0 + ENDIF + ENDIF + IF( NINT(phy_nat(i,k)).EQ.0 ) THEN + IF ( phy_rug(i,k).NE.0.001 ) phy_rug(i,k) = 0.001 + ENDIF + END DO + ENDIF + ENDDO +c + + ierr = NF_CLOSE(ncid) +c + DEALLOCATE( dlon ) + DEALLOCATE( dlon_ini ) + DEALLOCATE( dlat ) + DEALLOCATE( dlat_ini ) + DEALLOCATE( champ ) + +477 continue +c +C Traitement de la sst +c + PRINT*, 'Traitement de la sst' +c ierr = NF_OPEN('AMIP_SST.nc', NF_NOWRITE, ncid) + ierr = NF_OPEN('amipbc_sst_1x1.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + ierr = NF_OPEN('amipbc_sst_1x1_clim.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) THEN + print *, NF_STRERROR(ierr) + STOP + endif + ENDIF + +cIM22/02/2002 +cIM ierr = NF_INQ_VARID(ncid,'SST',varid) + ierr = NF_INQ_VARID(ncid,'tosbcs',varid) +cIM22/02/2002 + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable SST ', namedim,'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlon_ini(imdep) ) + ALLOCATE( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable SST ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( dlat_ini(jmdep) ) + ALLOCATE( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', lmdep +cIM28/02/2002 +cPM28/02/2002 : nouvelle coord temporelle fichiers AMIP pas en jours +c Ici on suppose qu'on a 12 mois (de 30 jours). + IF (lmdep.NE.12) THEN + print *, 'Unknown AMIP file: not 12 months ?' + STOP + ENDIF +cIM28/02/2002 + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE( champ(imdep, jmdep) ) + IF( extrap ) THEN + ALLOCATE ( work(imdep,jmdep) ) + ENDIF +c + DO l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title='Sst Amip' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) + IF ( extrap ) THEN + CALL extrapol(champ, imdep, jmdep, 999999.,.TRUE.,.TRUE.,2,work) + ENDIF +c + + IF ( interbar ) THEN + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour la Sst Amip $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF + CALL inter_barxy (dlon, dlat(:jmdep -1), champ, rlonu(:iim), + $ rlatv, champint) + ELSE + CALL grille_m(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ENDIF + + DO j = 1,jjp1 + DO i = 1, iim + champtime (i,j,l) = champint(i,j) + ENDDO + ENDDO + ENDDO +c + DO l = 1, lmdep +cIM28/02/2002 <==PM timeyear(l) = timecoord(l) + timeyear(l) = tmidmonth(l) + ENDDO + print 222, timeyear(:lmdep) +c +C interpolation temporelle + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i,j,l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = REAL(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1,j,k) = champan(1,j,k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' SST au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c +cIM14/03/2002 : SST amipbc greater then 271.38 + PRINT*,'SUB. limit_netcdf.F IM : SST Amipbc >= 271.38 ' + DO k = 1, 360 + DO j = 1, jjp1 + DO i = 1, iim + champan(i, j, k) = amax1(champan(i, j, k), 271.38) + ENDDO + champan(iip1, j, k) = champan(1, j, k) + ENDDO + ENDDO +cIM14/03/2002 + DO k = 1, 360 + CALL gr_dyn_fi(1, iip1, jjp1, klon, + . champan(1,1,k), phy_sst(1,k)) + ENDDO +c + ierr = NF_CLOSE(ncid) +c + DEALLOCATE( dlon ) + DEALLOCATE( dlon_ini ) + DEALLOCATE( dlat ) + DEALLOCATE( dlat_ini ) + DEALLOCATE( champ ) +c +C Traitement de l'albedo +c + PRINT*, 'Traitement de l albedo' + ierr = NF_OPEN('Albedo.nc', NF_NOWRITE, ncid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARID(ncid,'ALBEDO',varid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_VARDIMID (ncid,varid,ndimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(1), namedim, imdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', imdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlon_ini(imdep) ) + ALLOCATE ( dlon(imdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlon_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlon_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(2), namedim, jmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', jmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + ALLOCATE ( dlat_ini(jmdep) ) + ALLOCATE ( dlat(jmdep) ) + +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,dlat_ini) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,dlat_ini) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + ierr = NF_INQ_DIM(ncid,ndimid(3), namedim, lmdep) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + print*,'variable ', namedim, 'dimension ', lmdep + ierr = NF_INQ_VARID(ncid,namedim,dimid) + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +#ifdef NC_DOUBLE + ierr = NF_GET_VAR_DOUBLE(ncid,dimid,timecoord) +#else + ierr = NF_GET_VAR_REAL(ncid,dimid,timecoord) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF +c + ALLOCATE ( champ(imdep, jmdep) ) + + DO l = 1, lmdep + dimfirst(1) = 1 + dimfirst(2) = 1 + dimfirst(3) = l +c + dimlast(1) = imdep + dimlast(2) = jmdep + dimlast(3) = 1 +c + PRINT*,'Lecture temporelle et int. horizontale ',l,timecoord(l) +#ifdef NC_DOUBLE + ierr = NF_GET_VARA_DOUBLE(ncid,varid,dimfirst,dimlast,champ) +#else + ierr = NF_GET_VARA_REAL(ncid,varid,dimfirst,dimlast,champ) +#endif + if (ierr.ne.0) then + print *, NF_STRERROR(ierr) + STOP + ENDIF + + title='Albedo Amip' +c + CALL conf_dat2d(title,imdep, jmdep, dlon_ini, dlat_ini, + . dlon, dlat, champ, interbar ) +c +c + IF ( interbar ) THEN + IF( l.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour l Albedo Amip $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'------------------------' + ENDIF + + CALL inter_barxy(dlon, dlat(:jmdep-1), champ, rlonu(:iim), + $ rlatv, champint) + ELSE + CALL grille_m(imdep, jmdep, dlon, dlat, champ, + . iim, jjp1, rlonv, rlatu, champint ) + ENDIF +c + DO j = 1,jjp1 + DO i = 1, iim + champtime (i, j, l) = champint(i, j) + ENDDO + ENDDO + ENDDO +c + DO l = 1, lmdep + timeyear(l) = timecoord(l) + ENDDO + print 222, timeyear(:lmdep) +c +C interpolation temporelle + DO j = 1, jjp1 + DO i = 1, iim + DO l = 1, lmdep + ax(l) = timeyear(l) + ay(l) = champtime (i, j, l) + ENDDO + CALL SPLINE(ax,ay,lmdep,1.e30,1.e30,yder) + DO k = 1, 360 + time = REAL(k-1) + CALL SPLINT(ax,ay,yder,lmdep,time,by) + champan(i,j,k) = by + ENDDO + ENDDO + ENDDO + DO k = 1, 360 + DO j = 1, jjp1 + champan(iip1, j, k) = champan(1, j, k) + ENDDO + IF ( k.EQ.10 ) THEN + DO j = 1, jjp1 + CALL minmax( iip1,champan(1,j,10),chmin,chmax ) + PRINT *,' Albedo au temps 10 ', chmin,chmax,j + ENDDO + ENDIF + ENDDO +c + DO k = 1, 360 + CALL gr_dyn_fi(1, iip1, jjp1, klon, + . champan(1,1,k), phy_alb(1,k)) + ENDDO +c + ierr = NF_CLOSE(ncid) +c +c + DO k = 1, 360 + DO i = 1, klon + phy_bil(i,k) = 0.0 + ENDDO + ENDDO +c + PRINT*, 'Ecriture du fichier limit' +c + ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid) +c + ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30, + . "Fichier conditions aux limites") + ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim) + ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim) +c + dims(1) = ndim + dims(2) = ntim +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim) +#else + ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17, + . "Jour dans l annee") + IF (newlmt) THEN +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FOCE", NF_DOUBLE, 2,dims, id_FOCE) +#else + ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 14, + . "Fraction ocean") +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FSIC", NF_DOUBLE, 2,dims, id_FSIC) +#else + ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 21, + . "Fraction glace de mer") +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FTER", NF_DOUBLE, 2,dims, id_FTER) +#else + ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 14, + . "Fraction terre") +c +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "FLIC", NF_DOUBLE, 2,dims, id_FLIC) +#else + ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 17, + . "Fraction land ice") +c + ELSE +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT) +#else + ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23, + . "Nature du sol (0,1,2,3)") + ENDIF +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST) +#else + ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35, + . "Temperature superficielle de la mer") +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS) +#else + ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32, + . "Reference flux de chaleur au sol") +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB) +#else + ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19, + . "Albedo a la surface") +#ifdef NC_DOUBLE + ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG) +#else + ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG) +#endif + ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8, + . "Rugosite") +c + ierr = NF_ENDDEF(nid) +c + DO k = 1, 360 +c + debut(1) = 1 + debut(2) = k + epais(1) = klon + epais(2) = 1 +c +#ifdef NC_DOUBLE + ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k)) +c + IF (newlmt ) THEN + ierr = NF_PUT_VARA_DOUBLE (nid,id_FOCE,debut,epais + $ ,pctsrf_t(1,is_oce,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FSIC,debut,epais + $ ,pctsrf_t(1,is_sic,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FTER,debut,epais + $ ,pctsrf_t(1,is_ter,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_FLIC,debut,epais + $ ,pctsrf_t(1,is_lic,k)) + ELSE + ierr = NF_PUT_VARA_DOUBLE (nid,id_NAT,debut,epais + $ ,phy_nat(1,k)) + ENDIF +c + ierr = NF_PUT_VARA_DOUBLE (nid,id_SST,debut,epais,phy_sst(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_BILS,debut,epais,phy_bil(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_ALB,debut,epais,phy_alb(1,k)) + ierr = NF_PUT_VARA_DOUBLE (nid,id_RUG,debut,epais,phy_rug(1,k)) +#else + ierr = NF_PUT_VAR1_REAL (nid,id_tim,k, REAL(k)) + IF (newlmt ) THEN + ierr = NF_PUT_VARA_REAL (nid,id_FOCE,debut,epais + $ ,pctsrf_t(1,is_oce,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FSIC,debut,epais + $ ,pctsrf_t(1,is_sic,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FTER,debut,epais + $ ,pctsrf_t(1,is_ter,k)) + ierr = NF_PUT_VARA_REAL (nid,id_FLIC,debut,epais + $ ,pctsrf_t(1,is_lic,k)) + ELSE + ierr = NF_PUT_VARA_REAL (nid,id_NAT,debut,epais + $ ,phy_nat(1,k)) + ENDIF + ierr = NF_PUT_VARA_REAL (nid,id_SST,debut,epais,phy_sst(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_BILS,debut,epais,phy_bil(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_ALB,debut,epais,phy_alb(1,k)) + ierr = NF_PUT_VARA_REAL (nid,id_RUG,debut,epais,phy_rug(1,k)) +#endif +c + ENDDO +c + ierr = NF_CLOSE(nid) +c +#else + WRITE(lunout,*) + & 'limit_netcdf: Earth-specific routine, needs Earth physics' +#endif +! of #ifdef CPP_EARTH + STOP + END Index: /LMDZ5/trunk/libf/dyn3dmem/limx.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/limx.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/limx.F (revision 1632) @@ -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/dyn3dmem/limy.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/limy.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/limy.F (revision 1632) @@ -0,0 +1,193 @@ +! +! $Header$ +! + 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,apn,aps,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, ismin,ismax + + 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 apn=abs(dyq(1)/dyqv(iip1+1)) +c print*,dyq(ip1jm+1) +c print*,dyqv(ip1jm-iip1+1) +c aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +c do ij=2,iim +c apn=amax1(abs(dyq(ij)/dyqv(ij)),apn) +c aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps) +c enddo +c apn=min(pente_max/apn,1.) +c aps=min(pente_max/aps,1.) + + +c cas ou on a un extremum au pole + +c if(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +c & apn=0. +c if(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +c & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +c & aps=0. + +c limitation des pentes aux poles +c do ij=1,iip1 +c dyq(ij)=apn*dyq(ij) +c dyq(ip1jm+ij)=aps*dyq(ip1jm+ij) +c enddo + +c 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/dyn3dmem/limz.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/limz.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/limz.F (revision 1632) @@ -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/dyn3dmem/logic.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/logic.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/logic.h (revision 1632) @@ -0,0 +1,19 @@ +! +! $Header$ +! +! +! +!----------------------------------------------------------------------- +! INCLUDE 'logic.h' + + COMMON/logic/ purmats,iflag_phys,forward,leapf,apphys, & + & statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus & + & ,read_start,ok_guide,ok_strato,ok_gradsfile + + LOGICAL purmats,forward,leapf,apphys,statcl,conser, & + & apdiss,apdelq,saison,ecripar,fxyhypb,ysinus & + & ,read_start,ok_guide,ok_strato,ok_gradsfile + + INTEGER iflag_phys +!$OMP THREADPRIVATE(/logic/) +!----------------------------------------------------------------------- Index: /LMDZ5/trunk/libf/dyn3dmem/massbar.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/massbar.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/massbar.F (revision 1632) @@ -0,0 +1,100 @@ +! +! $Header$ +! + SUBROUTINE massbar( masse, massebx, masseby ) +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebx,masseby sont des argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebx( ip1jmp1,llm ) , + * masseby( ip1jm,llm ) +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + DO 100 l = 1 , llm +c + DO ij = 1, ip1jmp1 - 1 + massebx(ij,l) = masse( ij, l) * alpha1p2( ij ) + + * masse(ij+1, l) * alpha3p4(ij+1 ) + ENDDO + +c .... correction pour massebx( iip1,j) ..... +c ... massebx(iip1,j)= massebx(1,j) ... +c +CDIR$ IVDEP + DO ij = iip1, ip1jmp1, iip1 + massebx( ij,l ) = massebx( ij - iim,l ) + ENDDO + + + DO ij = 1,ip1jm + masseby( ij,l ) = masse( ij , l ) * alpha2p3( ij ) + + * masse(ij+iip1, l ) * alpha1p4( ij+iip1 ) + ENDDO + +100 CONTINUE +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/massbar_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/massbar_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/massbar_loc.F (revision 1632) @@ -0,0 +1,117 @@ + SUBROUTINE massbar_loc( masse, massebx, masseby ) + +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebx,masseby sont des argum. de sortie pour le s-pg ... +c +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ijb_u:ije_u,llm ), massebx( ijb_u:ije_u,llm ) , + * masseby( ijb_v:ije_v,llm ) + INTEGER ij,l,ijb,ije +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 100 l = 1 , llm +c + ijb=ij_begin + ije=ij_end+iip1 + if (pole_sud) ije=ije-iip1 + + DO ij = ijb, ije - 1 + massebx(ij,l) = masse( ij, l) * alpha1p2( ij ) + + * masse(ij+1, l) * alpha3p4(ij+1 ) + ENDDO + +c .... correction pour massebx( iip1,j) ..... +c ... massebx(iip1,j)= massebx(1,j) ... +c +CDIR$ IVDEP + + + + DO ij = ijb+iim, ije+iim, iip1 + massebx( ij,l ) = massebx( ij - iim,l ) + ENDDO + + + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO ij = ijb,ije + masseby( ij,l ) = masse( ij , l ) * alpha2p3( ij ) + + * masse(ij+iip1, l ) * alpha1p4( ij+iip1 ) + ENDDO + +100 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/massbarxy.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/massbarxy.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/massbarxy.F (revision 1632) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE massbarxy( masse, massebxy ) +c +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebxy est un argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ip1jmp1,llm ), massebxy( ip1jm,llm ) +c + + DO 100 l = 1 , llm +c + DO 5 ij = 1, ip1jm - 1 + massebxy( ij,l ) = masse( ij ,l ) * alpha2( ij ) + + + masse( ij+1 ,l ) * alpha3( ij+1 ) + + + masse( ij+iip1,l ) * alpha1( ij+iip1 ) + + + masse( ij+iip2,l ) * alpha4( ij+iip2 ) + 5 CONTINUE + +c .... correction pour massebxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + massebxy( ij,l ) = massebxy( ij - iim,l ) + 7 CONTINUE + +100 CONTINUE +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/massbarxy_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/massbarxy_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/massbarxy_loc.F (revision 1632) @@ -0,0 +1,55 @@ + SUBROUTINE massbarxy_loc( masse, massebxy ) + USE parallel + implicit none +c ********************************************************************** +c +c Calcule les moyennes en x et y de la masse d'air dans chaque maille. +c ********************************************************************** +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. masse est un argum. d'entree pour le s-pg ... +c .. massebxy est un argum. de sortie pour le s-pg ... +c +c +c IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c + REAL masse( ijb_u:ije_u,llm ), massebxy( ijb_v:ije_v,llm ) +c + INTEGER ij,l,ijb,ije + + + ijb=ij_begin-iip1 + ije=ij_end + + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 100 l = 1 , llm +c + DO 5 ij = ijb, ije - 1 + massebxy( ij,l ) = masse( ij ,l ) * alpha2( ij ) + + + masse( ij+1 ,l ) * alpha3( ij+1 ) + + + masse( ij+iip1,l ) * alpha1( ij+iip1 ) + + + masse( ij+iip2,l ) * alpha4( ij+iip2 ) + 5 CONTINUE + +c .... correction pour massebxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = ijb+iip1-1, ije+iip1-1, iip1 + massebxy( ij,l ) = massebxy( ij - iim,l ) + 7 CONTINUE + +100 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/massdair.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/massdair.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/massdair.F (revision 1632) @@ -0,0 +1,109 @@ +! +! $Header$ +! + SUBROUTINE massdair( p, masse ) +c +c ********************************************************************* +c .... Calcule la masse d'air dans chaque maille .... +c ********************************************************************* +c +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. p est un argum. d'entree pour le s-pg ... +c .. masse est un argum.de sortie pour le s-pg ... +c +c .... p est defini aux interfaces des llm couches ..... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c +c ..... arguments .... +c + REAL p(ip1jmp1,llmp1), masse(ip1jmp1,llm) + +c .... Variables locales ..... + + INTEGER l,ij + REAL massemoyn, massemoys + + REAL SSUM +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + DO 100 l = 1 , llm +c + DO ij = 1, ip1jmp1 + masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) ) + ENDDO +c + DO ij = 1, ip1jmp1,iip1 + masse(ij+ iim,l) = masse(ij,l) + ENDDO +c +c DO ij = 1, iim +c masse( ij ,l) = masse( ij ,l) * aire( ij ) +c masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) +c ENDDO +c massemoyn = SSUM(iim,masse( 1 ,l),1)/ apoln +c massemoys = SSUM(iim,masse(ip1jm+1,l),1)/ apols +c DO ij = 1, iip1 +c masse( ij ,l ) = massemoyn +c masse(ij+ip1jm,l ) = massemoys +c ENDDO + +100 CONTINUE +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/massdair_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/massdair_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/massdair_loc.F (revision 1632) @@ -0,0 +1,120 @@ + SUBROUTINE massdair_loc( p, masse ) + USE parallel +c +c ********************************************************************* +c .... Calcule la masse d'air dans chaque maille .... +c ********************************************************************* +c +c Auteurs : P. Le Van , Fr. Hourdin . +c .......... +c +c .. p est un argum. d'entree pour le s-pg ... +c .. masse est un argum.de sortie pour le s-pg ... +c +c .... p est defini aux interfaces des llm couches ..... +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comgeom.h" +c +c ..... arguments .... +c + REAL p(ijb_u:ije_u,llmp1), masse(ijb_u:ije_u,llm) + +c .... Variables locales ..... + + INTEGER l,ij + INTEGER ijb,ije + REAL massemoyn, massemoys + + REAL SSUM + EXTERNAL SSUM +c +c +c Methode pour calculer massebx et masseby . +c ---------------------------------------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c On a : +c +c massebx(i,j) = masse(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c masse(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c masseby(i,j) = masse(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c masse(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c +c======================================================================= + + + + + ijb=ij_begin-iip1 + ije=ij_end+2*iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 100 l = 1 , llm +c + DO ij = ijb, ije + masse(ij,l) = airesurg(ij) * ( p(ij,l) - p(ij,l+1) ) + ENDDO +c + DO ij = ijb, ije,iip1 + masse(ij+ iim,l) = masse(ij,l) + ENDDO +c +c DO ij = 1, iim +c masse( ij ,l) = masse( ij ,l) * aire( ij ) +c masse(ij+ip1jm,l) = masse(ij+ip1jm,l) * aire(ij+ip1jm) +c ENDDO +c massemoyn = SSUM(iim,masse( 1 ,l),1)/ apoln +c massemoys = SSUM(iim,masse(ip1jm+1,l),1)/ apols +c DO ij = 1, iip1 +c masse( ij ,l ) = massemoyn +c masse(ij+ip1jm,l ) = massemoys +c ENDDO + +100 CONTINUE +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/minmax.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/minmax.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/minmax.F (revision 1632) @@ -0,0 +1,23 @@ +! +! $Header$ +! + SUBROUTINE minmax(imax, xi, zmin, zmax ) +c +c P. Le Van + + INTEGER imax + REAL xi(imax) + REAL zmin,zmax + INTEGER i + + zmin = xi(1) + zmax = xi(1) + + DO i = 2, imax + zmin = MIN( zmin,xi(i) ) + zmax = MAX( zmax,xi(i) ) + ENDDO + + RETURN + END + Index: /LMDZ5/trunk/libf/dyn3dmem/minmax2.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/minmax2.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/minmax2.F (revision 1632) @@ -0,0 +1,20 @@ +! +! $Header$ +! + SUBROUTINE minmax2(imax, jmax, lmax, xi, zmin, zmax ) +c + INTEGER lmax,jmax,imax + REAL xi(imax*jmax*lmax) + REAL zmin,zmax + INTEGER i + + zmin = xi(1) + zmax = xi(1) + + DO i = 2, imax*jmax*lmax + zmin = MIN( zmin,xi(i) ) + zmax = MAX( zmax,xi(i) ) + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/mod_const_para.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/mod_const_para.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/mod_const_para.F90 (revision 1632) @@ -0,0 +1,77 @@ +! +! $Id: mod_const_para.F90 1279 2009-12-10 09:02:56Z fairhead $ +! +MODULE mod_const_mpi + + INTEGER,SAVE :: COMM_LMDZ + INTEGER,SAVE :: MPI_REAL_LMDZ + + +CONTAINS + + SUBROUTINE Init_const_mpi +#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 +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + INTEGER :: comp_id + INTEGER :: thread_required + INTEGER :: thread_provided + CHARACTER(len = 6) :: type_ocean + +!$OMP MASTER + type_ocean = 'force ' + CALL getin('type_ocean', type_ocean) +!$OMP END MASTER +!$OMP BARRIER + + IF (type_ocean=='couple') THEN +#ifdef CPP_COUPLE +!$OMP MASTER + CALL prism_init_comp_proto (comp_id, 'lmdz.x', ierr) + CALL prism_get_localcomm_proto(COMM_LMDZ,ierr) +!$OMP END MASTER +#endif +#ifdef CPP_MPI + MPI_REAL_LMDZ=MPI_REAL8 +#endif + ELSE + CALL init_mpi + ENDIF + + END SUBROUTINE Init_const_mpi + + SUBROUTINE Init_mpi + IMPLICIT NONE +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + INTEGER :: thread_required + INTEGER :: thread_provided + +#ifdef CPP_MPI +!$OMP MASTER + thread_required=MPI_THREAD_SERIALIZED + + CALL MPI_INIT_THREAD(thread_required,thread_provided,ierr) + IF (thread_provided < thread_required) THEN + PRINT *,'Warning : The multithreaded level of MPI librairy do not provide the requiered level', & + ' in mod_const_mpi::Init_const_mpi' + ENDIF + COMM_LMDZ=MPI_COMM_WORLD + MPI_REAL_LMDZ=MPI_REAL8 +!$OMP END MASTER +#endif + + END SUBROUTINE Init_mpi + +END MODULE mod_const_mpi Index: /LMDZ5/trunk/libf/dyn3dmem/mod_filtreg_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/mod_filtreg_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/mod_filtreg_p.F (revision 1632) @@ -0,0 +1,403 @@ + MODULE mod_filtreg_p + + CONTAINS + + SUBROUTINE filtreg_p ( champ,jjb,jje, ibeg, iend, nlat, nbniv, + & ifiltre, iaire, griscal ,iter) + USE Parallel, only : OMP_CHUNK + USE mod_filtre_fft_loc + USE timer_filtre + + USE filtreg_mod + + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van 07/10/97 +c ------ +c +c Objet: filtre matriciel longitudinal ,avec les matrices precalculees +c pour l'operateur Filtre . +c ------ +c +c Arguments: +c ---------- +c +c +c ibeg..iend lattitude a filtrer +c nlat nombre de latitudes du champ +c nbniv nombre de niveaux verticaux a filtrer +c champ(iip1,nblat,nbniv) en entree : champ a filtrer +c en sortie : champ filtre +c ifiltre +1 Transformee directe +c -1 Transformee inverse +c +2 Filtre directe +c -2 Filtre inverse +c +c iaire 1 si champ intensif +c 2 si champ extensif (pondere par les aires) +c +c iter 1 filtre simple +c +c======================================================================= +c +c +c Variable Intensive +c ifiltre = 1 filtre directe +c ifiltre =-1 filtre inverse +c +c Variable Extensive +c ifiltre = 2 filtre directe +c ifiltre =-2 filtre inverse +c +c +#include "dimensions.h" +#include "paramet.h" +#include "coefils.h" +c + INTEGER jjb,jje,ibeg,iend,nlat,nbniv,ifiltre,iter + INTEGER i,j,l,k + INTEGER iim2,immjm + INTEGER jdfil1,jdfil2,jffil1,jffil2,jdfil,jffil + + REAL champ( iip1,jjb:jje,nbniv) + + LOGICAL griscal + INTEGER hemisph, iaire + + REAL :: champ_fft(iip1,jjb:jje,nbniv) + REAL :: champ_in(iip1,jjb:jje,nbniv) + + LOGICAL,SAVE :: first=.TRUE. +c$OMP THREADPRIVATE(first) + + REAL, DIMENSION(iip1,jjb:jje,nbniv) :: champ_loc + INTEGER :: ll_nb, nbniv_loc + REAL, SAVE :: sdd12(iim,4) +c$OMP THREADPRIVATE(sdd12) + + INTEGER, PARAMETER :: type_sddu=1 + INTEGER, PARAMETER :: type_sddv=2 + INTEGER, PARAMETER :: type_unsddu=3 + INTEGER, PARAMETER :: type_unsddv=4 + + INTEGER :: sdd1_type, sdd2_type + + IF (first) THEN + sdd12(1:iim,type_sddu) = sddu(1:iim) + sdd12(1:iim,type_sddv) = sddv(1:iim) + sdd12(1:iim,type_unsddu) = unsddu(1:iim) + sdd12(1:iim,type_unsddv) = unsddv(1:iim) + + CALL Init_timer + first=.FALSE. + ENDIF + +c$OMP MASTER + CALL start_timer +c$OMP END MASTER + +c-------------------------------------------------------c + + IF(ifiltre.EQ.1.or.ifiltre.EQ.-1) + & STOP'Pas de transformee simple dans cette version' + + IF( iter.EQ. 2 ) THEN + PRINT *,' Pas d iteration du filtre dans cette version !' + & , ' Utiliser old_filtreg et repasser !' + STOP + ENDIF + + IF( ifiltre.EQ. -2 .AND..NOT.griscal ) THEN + PRINT *,' Cette routine ne calcule le filtre inverse que ' + & , ' sur la grille des scalaires !' + STOP + ENDIF + + IF( ifiltre.NE.2 .AND.ifiltre.NE. - 2 ) THEN + PRINT *,' Probleme dans filtreg car ifiltre NE 2 et NE -2' + & , ' corriger et repasser !' + STOP + ENDIF +c + + iim2 = iim * iim + immjm = iim * jjm +c +c + IF( griscal ) THEN + IF( nlat. NE. jjp1 ) THEN + PRINT 1111 + STOP + ELSE +c + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddv + sdd2_type = type_unsddv + ELSE + sdd1_type = type_unsddv + sdd2_type = type_sddv + ENDIF +c + jdfil1 = 2 + jffil1 = jfiltnu + jdfil2 = jfiltsu + jffil2 = jjm + ENDIF + ELSE + IF( nlat.NE.jjm ) THEN + PRINT 2222 + STOP + ELSE +c + IF( iaire.EQ.1 ) THEN + sdd1_type = type_sddu + sdd2_type = type_unsddu + ELSE + sdd1_type = type_unsddu + sdd2_type = type_sddu + ENDIF +c + jdfil1 = 1 + jffil1 = jfiltnv + jdfil2 = jfiltsv + jffil2 = jjm + ENDIF + ENDIF +c + DO hemisph = 1, 2 +c + IF ( hemisph.EQ.1 ) THEN +cym + jdfil = max(jdfil1,ibeg) + jffil = min(jffil1,iend) + ELSE +cym + jdfil = max(jdfil2,ibeg) + jffil = min(jffil2,iend) + ENDIF + + +cccccccccccccccccccccccccccccccccccccccccccc +c Utilisation du filtre classique +cccccccccccccccccccccccccccccccccccccccccccc + + IF (.NOT. use_filtre_fft) THEN + +c !---------------------------------! +c ! Agregation des niveau verticaux ! +c ! uniquement necessaire pour une ! +c ! execution OpenMP ! +c !---------------------------------! + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv + ll_nb = ll_nb+1 + DO j = jdfil,jffil + DO i = 1, iim + champ_loc(i,j,ll_nb) = + & champ(i,j,l) * sdd12(i,sdd1_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + nbniv_loc = ll_nb + + IF( hemisph.EQ.1 ) THEN + + IF( ifiltre.EQ.-2 ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matrinvn(1,1,j), iim, + & champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, + & champ_fft(1,j,1), iip1*(jje-jjb+1)) + ENDDO + + ELSE IF ( griscal ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matriceun(1,1,j), iim, + & champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, + & champ_fft(1,j,1), iip1*(jje-jjb+1)) + ENDDO + + ELSE + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matricevn(1,1,j), iim, + & champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, + & champ_fft(1,j,1), iip1*(jje-jjb+1)) + ENDDO + + ENDIF + + ELSE + + IF( ifiltre.EQ.-2 ) THEN + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matrinvs(1,1,j-jfiltsu+1), iim, + & champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, + & champ_fft(1,j,1), iip1*(jje-jjb+1)) + ENDDO + + ELSE IF ( griscal ) THEN + + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matriceus(1,1,j-jfiltsu+1), iim, + & champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, + & champ_fft(1,j,1), iip1*(jje-jjb+1)) + ENDDO + + ELSE + + DO j = jdfil,jffil + CALL DGEMM("N", "N", iim, nbniv_loc, iim, 1.0, + & matricevs(1,1,j-jfiltsv+1), iim, + & champ_loc(1,j,1), iip1*(jje-jjb+1), 0.0, + & champ_fft(1,j,1), iip1*(jje-jjb+1)) + ENDDO + + ENDIF + + ENDIF +! c + IF( ifiltre.EQ.2 ) THEN + +c !-------------------------------------! +c ! Dés-agregation des niveau verticaux ! +c ! uniquement necessaire pour une ! +c ! execution OpenMP ! +c !-------------------------------------! + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv_loc + ll_nb = ll_nb + 1 + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = (champ_loc(i,j,ll_nb) + & + champ_fft(i,j,ll_nb)) + & * sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ELSE + + ll_nb = 0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv_loc + ll_nb = ll_nb + 1 + DO j = jdfil,jffil + DO i = 1, iim + champ( i,j,l ) = (champ_loc(i,j,ll_nb) + & - champ_fft(i,j,ll_nb)) + & * sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ENDIF + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, nbniv + DO j = jdfil,jffil + champ( iip1,j,l ) = champ( 1,j,l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +ccccccccccccccccccccccccccccccccccccccccccccc +c Utilisation du filtre FFT +ccccccccccccccccccccccccccccccccccccccccccccc + + ELSE + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ( i,j,l)= champ(i,j,l)*sdd12(i,sdd1_type) + champ_fft( i,j,l) = champ(i,j,l) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + + IF (jdfil<=jffil) THEN + IF( ifiltre. EQ. -2 ) THEN + CALL Filtre_inv_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv) + ELSE IF ( griscal ) THEN + CALL Filtre_u_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv) + ELSE + CALL Filtre_v_fft(champ_fft,jjb,jje,jdfil,jffil,nbniv) + ENDIF + ENDIF + + + IF( ifiltre.EQ. 2 ) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ( i,j,l)=(champ(i,j,l)+champ_fft(i,j,l)) + & *sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + ELSE + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil + DO i = 1, iim + champ(i,j,l)=(champ(i,j,l)-champ_fft(i,j,l)) + & *sdd12(i,sdd2_type) + ENDDO + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,nbniv + DO j=jdfil,jffil +! champ_FFT( iip1,j,l ) = champ_FFT( 1,j,l ) + champ( iip1,j,l ) = champ( 1,j,l ) + ENDDO + ENDDO +c$OMP END DO NOWAIT + ENDIF +c Fin de la zone de filtrage + + + ENDDO + +! DO j=1,nlat +! +! PRINT *,"check FFT ----> Delta(",j,")=", +! & sum(champ(:,j,:)-champ_fft(:,j,:))/sum(champ(:,j,:)), +! & sum(champ(:,j,:)-champ_in(:,j,:))/sum(champ(:,j,:)) +! ENDDO + +! PRINT *,"check FFT ----> Delta(",j,")=", +! & sum(champ-champ_fft)/sum(champ) +! + +c + 1111 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a + & filtrer, sur la grille des scalaires'/) + 2222 FORMAT(//20x,'ERREUR dans le dimensionnement du tableau CHAMP a fi + & ltrer, sur la grille de V ou de Z'/) +c$OMP MASTER + CALL stop_timer +c$OMP END MASTER + RETURN + END SUBROUTINE filtreg_p + END MODULE mod_filtreg_p Index: /LMDZ5/trunk/libf/dyn3dmem/mod_hallo.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/mod_hallo.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/mod_hallo.F90 (revision 1632) @@ -0,0 +1,1612 @@ +module mod_Hallo +USE parallel +implicit none + logical,save :: use_mpi_alloc + integer, parameter :: MaxRequest=200 + integer, parameter :: MaxProc=512 + integer, parameter :: MaxBufferSize=1024*1024*100 + integer, parameter :: ListSize=1000 + + integer,save :: MaxBufferSize_Used +!$OMP THREADPRIVATE( MaxBufferSize_Used) + + real,save,pointer,dimension(:) :: Buffer +!$OMP THREADPRIVATE(Buffer) + + integer,save,dimension(Listsize) :: Buffer_Pos + integer,save :: Index_Pos +!$OMP THREADPRIVATE(Buffer_Pos,Index_pos) + + type Hallo + real, dimension(:,:),pointer :: Field + integer :: offset + integer :: size + integer :: NbLevel + integer :: Stride + end type Hallo + + type request_SR + integer :: NbRequest=0 + integer :: BufferSize + integer :: Pos + integer :: Index + type(Hallo),dimension(MaxRequest) :: Hallo + integer :: MSG_Request + end type request_SR + + type request + type(request_SR),dimension(0:MaxProc-1) :: RequestSend + type(request_SR),dimension(0:MaxProc-1) :: RequestRecv + integer :: tag=1 + end type request + + TYPE(distrib),SAVE :: distrib_gather + + + INTERFACE Register_SwapField_u + MODULE PROCEDURE Register_SwapField1d_u,Register_SwapField2d_u1d,Register_SwapField3d_u + END INTERFACE Register_SwapField_u + + INTERFACE Register_SwapField_v + MODULE PROCEDURE Register_SwapField1d_v,Register_SwapField2d_v1d,Register_SwapField3d_v + END INTERFACE Register_SwapField_v + + INTERFACE Register_SwapField2d_u + MODULE PROCEDURE Register_SwapField1d_u2d,Register_SwapField2d_u2d,Register_SwapField3d_u2d + END INTERFACE Register_SwapField2d_u + + INTERFACE Register_SwapField2d_v + MODULE PROCEDURE Register_SwapField1d_v2d,Register_SwapField2d_v2d,Register_SwapField3d_v2d + END INTERFACE Register_SwapField2d_v + + contains + + subroutine Init_mod_hallo + USE dimensions + implicit none + integer :: jj_nb_gather(0:mpi_size-1) + + Index_Pos=1 + Buffer_Pos(Index_Pos)=1 + MaxBufferSize_Used=0 + + IF (use_mpi_alloc .AND. using_mpi) THEN + CALL create_global_mpi_buffer + ELSE + CALL create_standard_mpi_buffer + ENDIF + + jj_nb_gather(:)=0 + jj_nb_gather(0)=jjp1 + + CALL create_distrib(jj_nb_gather,distrib_gather) + + end subroutine init_mod_hallo + + SUBROUTINE create_standard_mpi_buffer + IMPLICIT NONE + + ALLOCATE(Buffer(MaxBufferSize)) + + END SUBROUTINE create_standard_mpi_buffer + + SUBROUTINE create_global_mpi_buffer + IMPLICIT NONE +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + POINTER (Pbuffer,MPI_Buffer(MaxBufferSize)) + REAL :: MPI_Buffer +#ifdef CPP_MPI + INTEGER(KIND=MPI_ADDRESS_KIND) :: BS +#else + INTEGER(KIND=8) :: BS +#endif + INTEGER :: i,ierr + +! Allocation du buffer MPI + Bs=8*MaxBufferSize +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + CALL MPI_ALLOC_MEM(BS,MPI_INFO_NULL,Pbuffer,ierr) +#endif +!$OMP END CRITICAL (MPI) + DO i=1,MaxBufferSize + MPI_Buffer(i)=i + ENDDO + + CALL Associate_buffer(MPI_Buffer) + + CONTAINS + + SUBROUTINE Associate_buffer(MPI_Buffer) + IMPLICIT NONE + REAL,DIMENSION(:),target :: MPI_Buffer + + Buffer=>MPI_Buffer + + END SUBROUTINE Associate_buffer + + END SUBROUTINE create_global_mpi_buffer + + + subroutine allocate_buffer(Size,Index,Pos) + implicit none + integer :: Size + integer :: Index + integer :: Pos + + if (Buffer_pos(Index_pos)+Size>MaxBufferSize_Used) MaxBufferSize_Used=Buffer_pos(Index_pos)+Size + if (Buffer_pos(Index_pos)+Size>MaxBufferSize) then + print *,'STOP :: La taille de MaxBufferSize dans mod_hallo.F90 est trop petite !!!!' + stop + endif + + if (Index_pos>=ListSize) then + print *,'STOP :: La taille de ListSize dans mod_hallo.F90 est trop petite !!!!' + stop + endif + + Pos=Buffer_Pos(Index_Pos) + Buffer_Pos(Index_pos+1)=Buffer_Pos(Index_Pos)+Size + Index_Pos=Index_Pos+1 + Index=Index_Pos + + end subroutine allocate_buffer + + subroutine deallocate_buffer(Index) + implicit none + integer :: Index + + Buffer_Pos(Index)=-1 + + do while (Buffer_Pos(Index_Pos)==-1 .and. Index_Pos>1) + Index_Pos=Index_Pos-1 + end do + + end subroutine deallocate_buffer + + subroutine SetTag(a_request,tag) + implicit none + type(request):: a_request + integer :: tag + + a_request%tag=tag + end subroutine SetTag + + + subroutine Init_Hallo(Field,Stride,NbLevel,offset,size,NewHallo) + integer :: Stride + integer :: NbLevel + integer :: size + integer :: offset + real, dimension(Stride,NbLevel),target :: Field + type(Hallo) :: NewHallo + + NewHallo%Field=>Field + NewHallo%Stride=Stride + NewHallo%NbLevel=NbLevel + NewHallo%size=size + NewHallo%offset=offset + + + end subroutine Init_Hallo + + subroutine Register_SendField(Field,ij,ll,offset,size,target,a_request) + USE dimensions + implicit none + + + INTEGER :: ij,ll,offset,size,target + REAL, dimension(ij,ll) :: Field + type(request),target :: a_request + type(request_SR),pointer :: Ptr_request + + Ptr_Request=>a_request%RequestSend(target) + Ptr_Request%NbRequest=Ptr_Request%NbRequest+1 + if (Ptr_Request%NbRequest>=MaxRequest) then + print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!' + stop + endif + call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest)) + + end subroutine Register_SendField + + subroutine Register_RecvField(Field,ij,ll,offset,size,target,a_request) + USE dimensions + implicit none + + + INTEGER :: ij,ll,offset,size,target + REAL, dimension(ij,ll) :: Field + type(request),target :: a_request + type(request_SR),pointer :: Ptr_request + + Ptr_Request=>a_request%RequestRecv(target) + Ptr_Request%NbRequest=Ptr_Request%NbRequest+1 + + if (Ptr_Request%NbRequest>=MaxRequest) then + print *,'STOP :: La taille de MaxRequest dans mod_hallo.F90 est trop petite !!!!' + stop + endif + + call Init_Hallo(Field,ij,ll,offset,size,Ptr_request%Hallo(Ptr_Request%NbRequest)) + + + end subroutine Register_RecvField + + subroutine Register_SwapField(FieldS,FieldR,ij,ll,jj_Nb_New,a_request) + USE dimensions + implicit none + + + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + type(request) :: a_request + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + do i=0,MPI_Size-1 + if (i /= MPI_Rank) then + jjb=max(jj_begin_new(i),jj_begin) + jje=min(jj_end_new(i),jj_end) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i)) + jje=min(jj_end_new(MPI_Rank),jj_end_Para(i)) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + endif + enddo + + end subroutine Register_SwapField + + + + subroutine Register_SwapFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down,a_request) + USE dimensions + + implicit none + + INTEGER :: ij,ll,Up,Down + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + type(request) :: a_request + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + do i=0,MPI_Size-1 + jj_begin_New(i)=max(1,jj_begin_New(i)-Up) + jj_end_New(i)=min(jjp1,jj_end_new(i)+Down) + enddo + + do i=0,MPI_Size-1 + if (i /= MPI_Rank) then + jjb=max(jj_begin_new(i),jj_begin) + jje=min(jj_end_new(i),jj_end) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_SendField(FieldS,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + jjb=max(jj_begin_new(MPI_Rank),jj_begin_Para(i)) + jje=min(jj_end_new(MPI_Rank),jj_end_Para(i)) + + if (ij==ip1jm .and. jje==jjp1) jje=jjm + + if (jje >= jjb) then + call Register_RecvField(FieldR,ij,ll,jjb,jje-jjb+1,i,a_request) + endif + + endif + enddo + + end subroutine Register_SwapFieldHallo + + + + SUBROUTINE Register_SwapField1d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + IMPLICIT NONE + + REAL, DIMENSION(:),INTENT(IN) :: FieldS + REAL, DIMENSION(:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField1d_u + + + SUBROUTINE Register_SwapField2d_u1d(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + IMPLICIT NONE + + REAL, DIMENSION(:,:),INTENT(IN) :: FieldS + REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + INTEGER :: ll + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + ll=size(FieldS,2) + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField2d_u1d + + + SUBROUTINE Register_SwapField3d_u(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + IMPLICIT NONE + + REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS + REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + INTEGER :: ll + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + ll=size(FieldS,2)*size(FieldS,3) + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField3d_u + + + + SUBROUTINE Register_SwapField1d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + + IMPLICIT NONE + + REAL, DIMENSION(:,:),INTENT(IN) :: FieldS + REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),OPTIONAL,INTENT(IN) :: new_dist !LF + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_u(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_u(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField1d_u2d + + + SUBROUTINE Register_SwapField2d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + + IMPLICIT NONE + + REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS + REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + INTEGER :: ll + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + ll=size(FieldS,3) + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField2d_u2d + + + SUBROUTINE Register_SwapField3d_u2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + IMPLICIT NONE + + REAL, DIMENSION(:,:,:,:),INTENT(IN) :: FieldS + REAL, DIMENSION(:,:,:,:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + INTEGER :: ll + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + ll=size(FieldS,3)*size(FieldS,4) + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_u(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField3d_u2d + + + + + + + + SUBROUTINE Register_SwapField1d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + IMPLICIT NONE + + REAL, DIMENSION(:),INTENT(IN) :: FieldS + REAL, DIMENSION(:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField1d_v + + + SUBROUTINE Register_SwapField2d_v1d(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + IMPLICIT NONE + + REAL, DIMENSION(:,:),INTENT(IN) :: FieldS + REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + INTEGER :: ll + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + ll=size(FieldS,2) + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField2d_v1d + + + SUBROUTINE Register_SwapField3d_v(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + IMPLICIT NONE + + REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS + REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + INTEGER :: ll + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + ll=size(FieldS,2)*size(FieldS,3) + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField3d_v + + + + + SUBROUTINE Register_SwapField1d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + IMPLICIT NONE + + REAL, DIMENSION(:,:),INTENT(IN) :: FieldS + REAL, DIMENSION(:,:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),OPTIONAL,INTENT(IN) :: new_dist !LF + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_v(FieldS,FieldR,1,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_v(FieldS,FieldR,1,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField1d_v2d + + + SUBROUTINE Register_SwapField2d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + IMPLICIT NONE + + REAL, DIMENSION(:,:,:),INTENT(IN) :: FieldS + REAL, DIMENSION(:,:,:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + INTEGER :: ll + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + ll=size(FieldS,3) + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField2d_v2d + + + SUBROUTINE Register_SwapField3d_v2d(FieldS,FieldR,new_dist,a_request,old_dist,up,down) + USE parallel + USE dimensions + IMPLICIT NONE + + REAL, DIMENSION(:,:,:,:),INTENT(IN) :: FieldS + REAL, DIMENSION(:,:,:,:),INTENT(OUT) :: FieldR + TYPE(distrib),OPTIONAL,INTENT(IN) :: old_dist + TYPE(distrib),INTENT(IN) :: new_dist + INTEGER,OPTIONAL,INTENT(IN) :: up + INTEGER,OPTIONAL,INTENT(IN) :: down + TYPE(request),INTENT(INOUT) :: a_request + + INTEGER :: halo_up + INTEGER :: halo_down + INTEGER :: ll + + + halo_up=0 + halo_down=0 + IF (PRESENT(up)) halo_up=up + IF (PRESENT(down)) halo_down=down + + ll=size(FieldS,3)*size(FieldS,4) + + IF (PRESENT(old_dist)) THEN + CALL Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,halo_up,halo_down,a_request) + ELSE + CALL Register_SwapField_gen_v(FieldS,FieldR,ll,current_dist,new_dist,halo_up,halo_down,a_request) + ENDIF + + END SUBROUTINE Register_SwapField3d_v2d + + + + SUBROUTINE Register_SwapField_gen_u(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request) + USE parallel + USE dimensions + IMPLICIT NONE + + INTEGER :: ll,Up,Down + TYPE(distrib) :: old_dist + TYPE(distrib) :: new_dist + REAL, DIMENSION(old_dist%ijb_u:old_dist%ije_u,ll) :: FieldS + REAL, DIMENSION(new_dist%ijb_u:new_dist%ije_u,ll) :: FieldR + TYPE(request) :: a_request + INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New + INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + INTEGER ::i,l,jje,jjb,ijb,ije + + DO i=0,MPI_Size-1 + jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up) + jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down) + ENDDO + + DO i=0,MPI_Size-1 + IF (i /= MPI_Rank) THEN + jjb=max(jj_begin_new(i),old_dist%jj_begin) + jje=min(jj_end_new(i),old_dist%jj_end) + + IF (jje >= jjb) THEN + CALL Register_SendField(FieldS,old_dist%ijnb_u,ll,jjb-old_dist%jjb_u+1,jje-jjb+1,i,a_request) + ENDIF + + jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i)) + jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i)) + + IF (jje >= jjb) THEN + CALL Register_RecvField(FieldR,new_dist%ijnb_u,ll,jjb-new_dist%jjb_u+1,jje-jjb+1,i,a_request) + ENDIF + ELSE + jjb=max(jj_begin_new(i),old_dist%jj_begin) + jje=min(jj_end_new(i),old_dist%jj_end) + ijb=(jjb-1)*iip1+1 + ije=jje*iip1 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,ll + FieldR(ijb:ije,:)=FieldS(ijb:ije,:) + ENDDO +!$OMP END DO NOWAIT + ENDIF + ENDDO + + END SUBROUTINE Register_SwapField_gen_u + + + + SUBROUTINE Register_SwapField_gen_v(FieldS,FieldR,ll,old_dist,new_dist,Up,Down,a_request) + USE parallel + USE dimensions + IMPLICIT NONE + + INTEGER :: ll,Up,Down + TYPE(distrib) :: old_dist + TYPE(distrib) :: new_dist + REAL, DIMENSION(old_dist%ijb_v:old_dist%ije_v,ll) :: FieldS + REAL, DIMENSION(new_dist%ijb_v:new_dist%ije_v,ll) :: FieldR + TYPE(request) :: a_request + INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Nb_New + INTEGER,DIMENSION(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + INTEGER ::i,l,jje,jjb,ijb,ije + + DO i=0,MPI_Size-1 + jj_begin_New(i)=max(1,new_dist%jj_begin_para(i)-Up) + jj_end_New(i)=min(jjp1,new_dist%jj_end_para(i)+Down) + ENDDO + + DO i=0,MPI_Size-1 + IF (i /= MPI_Rank) THEN + jjb=max(jj_begin_new(i),old_dist%jj_begin) + jje=min(jj_end_new(i),old_dist%jj_end) + + IF (jje==jjp1) jje=jjm + + IF (jje >= jjb) THEN + CALL Register_SendField(FieldS,old_dist%ijnb_v,ll,jjb-old_dist%jjb_v+1,jje-jjb+1,i,a_request) + ENDIF + + jjb=max(jj_begin_new(MPI_Rank),old_dist%jj_begin_Para(i)) + jje=min(jj_end_new(MPI_Rank),old_dist%jj_end_Para(i)) + + IF (jje==jjp1) jje=jjm + + IF (jje >= jjb) THEN + CALL Register_RecvField(FieldR,new_dist%ijnb_v,ll,jjb-new_dist%jjb_v+1,jje-jjb+1,i,a_request) + ENDIF + ELSE + jjb=max(jj_begin_new(i),old_dist%jj_begin) + jje=min(jj_end_new(i),old_dist%jj_end) + IF (jje==jjp1) jje=jjm + ijb=(jjb-1)*iip1+1 + ije=jje*iip1 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,ll + FieldR(ijb:ije,l)=FieldS(ijb:ije,l) + ENDDO +!$OMP END DO NOWAIT + ENDIF + ENDDO + + END SUBROUTINE Register_SwapField_gen_v + + + + + + subroutine Register_Hallo(Field,ij,ll,RUp,Rdown,SUp,SDown,a_request) + USE dimensions + implicit none + +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: Sup,Sdown,rup,rdown + type(request) :: a_request + type(Hallo),pointer :: PtrHallo + LOGICAL :: SendUp,SendDown + LOGICAL :: RecvUp,RecvDown + + + SendUp=.TRUE. + SendDown=.TRUE. + RecvUp=.TRUE. + RecvDown=.TRUE. + + IF (pole_nord) THEN + SendUp=.FALSE. + RecvUp=.FALSE. + ENDIF + + IF (pole_sud) THEN + SendDown=.FALSE. + RecvDown=.FALSE. + ENDIF + + if (Sup.eq.0) then + SendUp=.FALSE. + endif + + if (Sdown.eq.0) then + SendDown=.FALSE. + endif + + if (Rup.eq.0) then + RecvUp=.FALSE. + endif + + if (Rdown.eq.0) then + RecvDown=.FALSE. + endif + + IF (SendUp) THEN + call Register_SendField(Field,ij,ll,jj_begin,SUp,MPI_Rank-1,a_request) + ENDIF + + IF (SendDown) THEN + call Register_SendField(Field,ij,ll,jj_end-SDown+1,SDown,MPI_Rank+1,a_request) + ENDIF + + + IF (RecvUp) THEN + call Register_RecvField(Field,ij,ll,jj_begin-Rup,RUp,MPI_Rank-1,a_request) + ENDIF + + IF (RecvDown) THEN + call Register_RecvField(Field,ij,ll,jj_end+1,RDown,MPI_Rank+1,a_request) + ENDIF + + end subroutine Register_Hallo + + + subroutine Register_Hallo_u(Field,ll,RUp,Rdown,SUp,SDown,a_request) + USE dimensions + implicit none +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ll + REAL, dimension(ijb_u:ije_u,ll) :: Field + INTEGER :: Sup,Sdown,rup,rdown + type(request) :: a_request + type(Hallo),pointer :: PtrHallo + LOGICAL :: SendUp,SendDown + LOGICAL :: RecvUp,RecvDown + + + SendUp=.TRUE. + SendDown=.TRUE. + RecvUp=.TRUE. + RecvDown=.TRUE. + + IF (pole_nord) THEN + SendUp=.FALSE. + RecvUp=.FALSE. + ENDIF + + IF (pole_sud) THEN + SendDown=.FALSE. + RecvDown=.FALSE. + ENDIF + + if (Sup.eq.0) then + SendUp=.FALSE. + endif + + if (Sdown.eq.0) then + SendDown=.FALSE. + endif + + if (Rup.eq.0) then + RecvUp=.FALSE. + endif + + if (Rdown.eq.0) then + RecvDown=.FALSE. + endif + + IF (SendUp) THEN + call Register_SendField(Field,ijnb_u,ll,jj_begin-jjb_u+1,SUp,MPI_Rank-1,a_request) + ENDIF + + IF (SendDown) THEN + call Register_SendField(Field,ijnb_u,ll,jj_end-SDown+1-jjb_u+1,SDown,MPI_Rank+1,a_request) + ENDIF + + + IF (RecvUp) THEN + call Register_RecvField(Field,ijnb_u,ll,jj_begin-Rup-jjb_u+1,RUp,MPI_Rank-1,a_request) + ENDIF + + IF (RecvDown) THEN + call Register_RecvField(Field,ijnb_u,ll,jj_end+1-jjb_u+1,RDown,MPI_Rank+1,a_request) + ENDIF + + end subroutine Register_Hallo_u + + subroutine Register_Hallo_v(Field,ll,RUp,Rdown,SUp,SDown,a_request) + USE dimensions + implicit none +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ll + REAL, dimension(ijb_v:ije_v,ll) :: Field + INTEGER :: Sup,Sdown,rup,rdown + type(request) :: a_request + type(Hallo),pointer :: PtrHallo + LOGICAL :: SendUp,SendDown + LOGICAL :: RecvUp,RecvDown + + + SendUp=.TRUE. + SendDown=.TRUE. + RecvUp=.TRUE. + RecvDown=.TRUE. + + IF (pole_nord) THEN + SendUp=.FALSE. + RecvUp=.FALSE. + ENDIF + + IF (pole_sud) THEN + SendDown=.FALSE. + RecvDown=.FALSE. + ENDIF + + if (Sup.eq.0) then + SendUp=.FALSE. + endif + + if (Sdown.eq.0) then + SendDown=.FALSE. + endif + + if (Rup.eq.0) then + RecvUp=.FALSE. + endif + + if (Rdown.eq.0) then + RecvDown=.FALSE. + endif + + IF (SendUp) THEN + call Register_SendField(Field,ijnb_v,ll,jj_begin-jjb_v+1,SUp,MPI_Rank-1,a_request) + ENDIF + + IF (SendDown) THEN + call Register_SendField(Field,ijnb_v,ll,jj_end-SDown+1-jjb_v+1,SDown,MPI_Rank+1,a_request) + ENDIF + + + IF (RecvUp) THEN + call Register_RecvField(Field,ijnb_v,ll,jj_begin-Rup-jjb_v+1,RUp,MPI_Rank-1,a_request) + ENDIF + + IF (RecvDown) THEN + call Register_RecvField(Field,ijnb_v,ll,jj_end+1-jjb_v+1,RDown,MPI_Rank+1,a_request) + ENDIF + + end subroutine Register_Hallo_v + + subroutine SendRequest(a_Request) + USE dimensions + implicit none + +#ifdef CPP_MPI + include 'mpif.h' +#endif + + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer :: SizeBuffer + integer :: i,rank,l,ij,Pos,ierr + integer :: offset + real,dimension(:,:),pointer :: Field + integer :: Nb + + do rank=0,MPI_SIZE-1 + + Req=>a_Request%RequestSend(rank) + + SizeBuffer=0 + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,PtrHallo%NbLevel + SizeBuffer=SizeBuffer+PtrHallo%size*iip1 + ENDDO +!$OMP ENDDO NOWAIT + enddo + + Req%BufferSize=SizeBuffer + if (Req%NbRequest>0) then + + call allocate_buffer(SizeBuffer,Req%Index,Req%pos) + + Pos=Req%Pos + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + offset=(PtrHallo%offset-1)*iip1+1 + Nb=iip1*PtrHallo%size-1 + Field=>PtrHallo%Field + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,PtrHallo%NbLevel +!cdir NODEP + do ij=0,Nb + Buffer(Pos+ij)=Field(Offset+ij,l) + enddo + + Pos=Pos+Nb+1 + enddo +!$OMP END DO NOWAIT + enddo + + if (SizeBuffer>0) then +!$OMP CRITICAL (MPI) + +#ifdef CPP_MPI + call MPI_ISSEND(Buffer(req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, & + COMM_LMDZ,Req%MSG_Request,ierr) +#endif + IF (.NOT.using_mpi) THEN + PRINT *,'Erreur, echange MPI en mode sequentiel !!!' + STOP + ENDIF +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->" +! PRINT *,"Requete envoye au proc :",rank,"tag :",a_request%tag+1000*omp_rank +! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request +! PRINT *,"-------------------------------------------------------------------" +!$OMP END CRITICAL (MPI) + endif + endif + enddo + + + do rank=0,MPI_SIZE-1 + + Req=>a_Request%RequestRecv(rank) + SizeBuffer=0 + + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,PtrHallo%NbLevel + SizeBuffer=SizeBuffer+PtrHallo%size*iip1 + ENDDO +!$OMP ENDDO NOWAIT + enddo + + Req%BufferSize=SizeBuffer + + if (Req%NbRequest>0) then + call allocate_buffer(SizeBuffer,Req%Index,Req%Pos) + + if (SizeBuffer>0) then + +!$OMP CRITICAL (MPI) + +#ifdef CPP_MPI + call MPI_IRECV(Buffer(Req%Pos),SizeBuffer,MPI_REAL_LMDZ,rank,a_request%tag+1000*omp_rank, & + COMM_LMDZ,Req%MSG_Request,ierr) +#endif + IF (.NOT.using_mpi) THEN + PRINT *,'Erreur, echange MPI en mode sequentiel !!!' + STOP + ENDIF + +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->" +! PRINT *,"Requete en attente du proc :",rank,"tag :",a_request%tag+1000*omp_rank +! PRINT *,"Taille du message :",SizeBuffer,"requete no :",Req%MSG_Request +! PRINT *,"-------------------------------------------------------------------" + +!$OMP END CRITICAL (MPI) + endif + endif + + enddo + + end subroutine SendRequest + + subroutine WaitRequest(a_Request) + USE dimensions + implicit none + +#ifdef CPP_MPI + include 'mpif.h' +#endif + + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer, dimension(2*mpi_size) :: TabRequest +#ifdef CPP_MPI + integer, dimension(MPI_STATUS_SIZE,2*mpi_size) :: TabStatus +#else + integer, dimension(1,2*mpi_size) :: TabStatus +#endif + integer :: NbRequest + integer :: i,rank,pos,ij,l,ierr + integer :: offset + integer :: Nb + + + NbRequest=0 + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0 .AND. Req%BufferSize > 0) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + if (NbRequest>0) then +!$OMP CRITICAL (MPI) +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente" +! PRINT *,"No des requetes :",TabRequest(1:NbRequest) +#ifdef CPP_MPI + call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr) +#endif +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete" +! PRINT *,"-------------------------------------------------------------------" +!$OMP END CRITICAL (MPI) + endif + do rank=0,MPI_Size-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + Pos=Req%Pos + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + offset=(PtrHallo%offset-1)*iip1+1 + Nb=iip1*PtrHallo%size-1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,PtrHallo%NbLevel +!cdir NODEP + do ij=0,Nb + PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij) + enddo + + Pos=Pos+Nb+1 + enddo +!$OMP ENDDO NOWAIT + enddo + endif + enddo + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + a_request%tag=1 + end subroutine WaitRequest + + subroutine WaitSendRequest(a_Request) + USE dimensions + implicit none + +#ifdef CPP_MPI + include 'mpif.h' +#endif + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer, dimension(mpi_size) :: TabRequest +#ifdef CPP_MPI + integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus +#else + integer, dimension(1,mpi_size) :: TabStatus +#endif + integer :: NbRequest + integer :: i,rank,pos,ij,l,ierr + integer :: offset + + + NbRequest=0 + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + + if (NbRequest>0 .AND. Req%BufferSize > 0 ) THEN +!$OMP CRITICAL (MPI) +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente" +! PRINT *,"No des requetes :",TabRequest(1:NbRequest) +#ifdef CPP_MPI + call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr) +#endif +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete" +! PRINT *,"-------------------------------------------------------------------" + +!$OMP END CRITICAL (MPI) + endif + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestSend(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + a_request%tag=1 + end subroutine WaitSendRequest + + subroutine WaitRecvRequest(a_Request) + USE dimensions + implicit none + +#ifdef CPP_MPI + include 'mpif.h' +#endif + + type(request),target :: a_request + type(request_SR),pointer :: Req + type(Hallo),pointer :: PtrHallo + integer, dimension(mpi_size) :: TabRequest +#ifdef CPP_MPI + integer, dimension(MPI_STATUS_SIZE,mpi_size) :: TabStatus +#else + integer, dimension(1,mpi_size) :: TabStatus +#endif + integer :: NbRequest + integer :: i,rank,pos,ij,l,ierr + integer :: offset,Nb + + + NbRequest=0 + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0 .AND. Req%BufferSize > 0 ) then + NbRequest=NbRequest+1 + TabRequest(NbRequest)=Req%MSG_Request + endif + enddo + + + if (NbRequest>0) then +!$OMP CRITICAL (MPI) +! PRINT *,"-------------------------------------------------------------------" +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"en attente" +! PRINT *,"No des requetes :",TabRequest(1:NbRequest) +#ifdef CPP_MPI + call MPI_WAITALL(NbRequest,TabRequest,TabStatus,ierr) +#endif +! PRINT *,"Process de rang",mpi_rank,"Task : ",omp_rank,"--->",NbRequest,"complete" +! PRINT *,"-------------------------------------------------------------------" +!$OMP END CRITICAL (MPI) + endif + + do rank=0,MPI_Size-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + Pos=Req%Pos + do i=1,Req%NbRequest + PtrHallo=>Req%Hallo(i) + offset=(PtrHallo%offset-1)*iip1+1 + Nb=iip1*PtrHallo%size-1 +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,PtrHallo%NbLevel +!cdir NODEP + do ij=0,Nb + PtrHallo%Field(offset+ij,l)=Buffer(Pos+ij) + enddo + Pos=Pos+Nb+1 + enddo +!$OMP END DO NOWAIT + enddo + endif + enddo + + + do rank=0,MPI_SIZE-1 + Req=>a_request%RequestRecv(rank) + if (Req%NbRequest>0) then + call deallocate_buffer(Req%Index) + Req%NbRequest=0 + endif + enddo + + a_request%tag=1 + end subroutine WaitRecvRequest + + + + subroutine CopyField(FieldS,FieldR,ij,ll,jj_Nb_New) + USE dimensions + + implicit none + + INTEGER :: ij,ll,l + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb,ijb,ije + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + jjb=max(jj_begin,jj_begin_new(MPI_Rank)) + jje=min(jj_end,jj_end_new(MPI_Rank)) + if (ij==ip1jm) jje=min(jje,jjm) + + if (jje >= jjb) then + ijb=(jjb-1)*iip1+1 + ije=jje*iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,ll + FieldR(ijb:ije,l)=FieldS(ijb:ije,l) + enddo +!$OMP ENDDO NOWAIT + endif + + + end subroutine CopyField + + subroutine CopyFieldHallo(FieldS,FieldR,ij,ll,jj_Nb_New,Up,Down) + USE dimensions + + implicit none + + INTEGER :: ij,ll,Up,Down + REAL, dimension(ij,ll) :: FieldS + REAL, dimension(ij,ll) :: FieldR + integer,dimension(0:MPI_Size-1) :: jj_Nb_New + integer,dimension(0:MPI_Size-1) :: jj_Begin_New,jj_End_New + + integer ::i,jje,jjb,ijb,ije,l + + + jj_begin_New(0)=1 + jj_End_New(0)=jj_Nb_New(0) + do i=1,MPI_Size-1 + jj_begin_New(i)=jj_end_New(i-1)+1 + jj_end_New(i)=jj_begin_new(i)+jj_Nb_New(i)-1 + enddo + + + jjb=max(jj_begin,jj_begin_new(MPI_Rank)-Up) + jje=min(jj_end,jj_end_new(MPI_Rank)+Down) + if (ij==ip1jm) jje=min(jje,jjm) + + + if (jje >= jjb) then + ijb=(jjb-1)*iip1+1 + ije=jje*iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,ll + FieldR(ijb:ije,l)=FieldS(ijb:ije,l) + enddo +!$OMP ENDDO NOWAIT + + endif + end subroutine CopyFieldHallo + + subroutine Gather_field_u(field_loc,field_glo,ll) + USE dimensions + implicit none + integer :: ll + real :: field_loc(ijb_u:ije_u,ll) + real :: field_glo(ip1jmp1,ll) + type(request) :: request_gather + integer :: l + + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,ll + field_glo(ij_begin:ij_end,l)=field_loc(ij_begin:ij_end,l) + ENDDO + + call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_gather%jj_nb_para,request_gather) + call SendRequest(request_gather) +!$OMP BARRIER + call WaitRequest(request_gather) +!$OMP BARRIER + + end subroutine Gather_field_u + + subroutine Gather_field_v(field_loc,field_glo,ll) + USE dimensions + implicit none + integer :: ll + real :: field_loc(ijb_v:ije_v,ll) + real :: field_glo(ip1jm,ll) + type(request) :: request_gather + integer :: ijb,ije + integer :: l + + + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,ll + field_glo(ijb:ije,l)=field_loc(ijb:ije,l) + ENDDO + + call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_gather%jj_nb_para,request_gather) + call SendRequest(request_gather) +!$OMP BARRIER + call WaitRequest(request_gather) +!$OMP BARRIER + + end subroutine Gather_field_v + + subroutine Scatter_field_u(field_glo,field_loc,ll) + USE dimensions + implicit none + integer :: ll + real :: field_glo(ip1jmp1,ll) + real :: field_loc(ijb_u:ije_u,ll) + type(request) :: request_gather + TYPE(distrib) :: distrib_swap + integer :: l + +!$OMP BARRIER +!$OMP MASTER + call get_current_distrib(distrib_swap) + call set_Distrib(distrib_gather) +!$OMP END MASTER +!$OMP BARRIER + + call register_SwapField(field_glo,field_glo,ip1jmp1,ll,distrib_swap%jj_nb_para,request_gather) + call SendRequest(request_gather) +!$OMP BARRIER + call WaitRequest(request_gather) +!$OMP BARRIER +!$OMP MASTER + call set_Distrib(distrib_swap) +!$OMP END MASTER +!$OMP BARRIER + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,ll + field_loc(ij_begin:ij_end,l)=field_glo(ij_begin:ij_end,l) + ENDDO + + end subroutine Scatter_field_u + + subroutine Scatter_field_v(field_glo,field_loc,ll) + USE dimensions + implicit none + integer :: ll + real :: field_glo(ip1jmp1,ll) + real :: field_loc(ijb_v:ije_v,ll) + type(request) :: request_gather + TYPE(distrib) :: distrib_swap + integer :: ijb,ije,l + + +!$OMP BARRIER +!$OMP MASTER + call get_current_distrib(distrib_swap) + call set_Distrib(distrib_gather) +!$OMP END MASTER +!$OMP BARRIER + call register_SwapField(field_glo,field_glo,ip1jm,ll,distrib_swap%jj_nb_para,request_gather) + call SendRequest(request_gather) +!$OMP BARRIER + call WaitRequest(request_gather) +!$OMP BARRIER +!$OMP MASTER + call set_Distrib(distrib_swap) +!$OMP END MASTER +!$OMP BARRIER + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,ll + field_loc(ijb:ije,l)=field_glo(ijb:ije,l) + ENDDO + + end subroutine Scatter_field_v + +end module mod_Hallo + Index: /LMDZ5/trunk/libf/dyn3dmem/mod_interface_dyn_phys.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/mod_interface_dyn_phys.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/mod_interface_dyn_phys.F90 (revision 1632) @@ -0,0 +1,59 @@ +! +! $Id: mod_interface_dyn_phys.F90 1279 2009-12-10 09:02:56Z fairhead $ +! +MODULE mod_interface_dyn_phys + INTEGER,SAVE,dimension(:),allocatable :: index_i + INTEGER,SAVE,dimension(:),allocatable :: index_j + + +#ifdef CPP_EARTH +! Interface with parallel physics, +! for now this routine only works with Earth physics +CONTAINS + + SUBROUTINE Init_interface_dyn_phys + USE mod_phys_lmdz_mpi_data + IMPLICIT NONE + include 'dimensions.h' + + INTEGER :: i,j,k + + ALLOCATE(index_i(klon_mpi)) + ALLOCATE(index_j(klon_mpi)) + + k=1 + IF (is_north_pole) THEN + index_i(k)=1 + index_j(k)=1 + k=2 + ELSE + DO i=ii_begin,iim + index_i(k)=i + index_j(k)=jj_begin + k=k+1 + ENDDO + ENDIF + + DO j=jj_begin+1,jj_end-1 + DO i=1,iim + index_i(k)=i + index_j(k)=j + k=k+1 + ENDDO + ENDDO + + IF (is_south_pole) THEN + index_i(k)=1 + index_j(k)=jj_end + ELSE + DO i=1,ii_end + index_i(k)=i + index_j(k)=jj_end + k=k+1 + ENDDO + ENDIF + + END SUBROUTINE Init_interface_dyn_phys +#endif +! of #ifdef CPP_EARTH +END MODULE mod_interface_dyn_phys Index: /LMDZ5/trunk/libf/dyn3dmem/nxgrad.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgrad.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgrad.F (revision 1632) @@ -0,0 +1,48 @@ +! +! $Header$ +! + SUBROUTINE nxgrad (klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/nxgrad_gam.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgrad_gam.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgrad_gam.F (revision 1632) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE nxgrad_gam( klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/nxgrad_gam_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgrad_gam_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgrad_gam_loc.F (revision 1632) @@ -0,0 +1,69 @@ + SUBROUTINE nxgrad_gam_loc( klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + USE parallel + + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ijb_v:ije_v,klevel ) + REAL x( ijb_u:ije_u,klevel ),y(ijb_v:ije_v,klevel ) + INTEGER l,ij + integer ismin,ismax + external ismin,ismax + INTEGER :: ijb,ije +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb+1, ije + y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = ijb, ije, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + ijb=ij_begin + ije=ij_end+iip1 + if(pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) + 4 CONTINUE + + if (pole_nord) then + DO ij = 1,iip1 + x( ij ,l ) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iip1 + x( ij +ip1jm,l ) = 0. + ENDDO + endif +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/nxgrad_gam_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgrad_gam_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgrad_gam_p.F (revision 1632) @@ -0,0 +1,67 @@ + SUBROUTINE nxgrad_gam_p( klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij + integer ismin,ismax + external ismin,ismax + INTEGER :: ijb,ije +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb+1, ije + y( ij,l ) = (rot( ij,l ) - rot( ij-1,l )) * cvscuvgam( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = ijb, ije, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + ijb=ij_begin + ije=ij_end+iip1 + if(pole_nord) ijb=ij_begin+iip1 + if(pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + x( ij,l ) = (rot( ij,l ) - rot( ij -iip1,l )) * cuscvugam( ij ) + 4 CONTINUE + + if (pole_nord) then + DO ij = 1,iip1 + x( ij ,l ) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iip1 + x( ij +ip1jm,l ) = 0. + ENDDO + endif +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/nxgrad_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgrad_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgrad_loc.F (revision 1632) @@ -0,0 +1,68 @@ + SUBROUTINE nxgrad_loc (klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ijb_v:ije_v,klevel ),x( ijb_u:ije_u,klevel ) + REAL y(ijb_v:ije_v,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije +c +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb+1, ije + y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = ijb, ije, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + ijb=ij_begin + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) + 4 CONTINUE + + if (pole_nord) then + DO ij = 1,iip1 + x( ij ,l ) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iip1 + x( ij +ip1jm,l ) = 0. + ENDDO + endif +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/nxgrad_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgrad_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgrad_p.F (revision 1632) @@ -0,0 +1,67 @@ + SUBROUTINE nxgrad_p (klevel, rot, x, y ) +c +c P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij + INTEGER :: ijb,ije +c +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + ijb=ij_begin + ije=ij_end + if (pole_sud) ije=ij_end-iip1 + + DO 1 ij = ijb+1, ije + y( ij,l ) = ( rot( ij,l ) - rot( ij-1,l ) ) * cvsurcuv( ij ) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... +CDIR$ IVDEP + DO 2 ij = ijb, ije, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + ijb=ij_begin + ije=ij_end+iip1 + + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO 4 ij = ijb,ije + x( ij,l ) = ( rot( ij,l ) - rot( ij -iip1,l ) ) * cusurcvu( ij ) + 4 CONTINUE + + if (pole_nord) then + DO ij = 1,iip1 + x( ij ,l ) = 0. + ENDDO + endif + + if (pole_sud) then + DO ij = 1,iip1 + x( ij +ip1jm,l ) = 0. + ENDDO + endif +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/nxgradst.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgradst.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgradst.F (revision 1632) @@ -0,0 +1,47 @@ +! +! $Header$ +! + SUBROUTINE nxgradst (klevel,rot, x, y ) +c + IMPLICIT NONE +c Auteur : P. Le Van +c +c ******************************************************************** +c calcul du gradient tourne de pi/2 du rotationnel du vect.v +c ******************************************************************** +c rot est un argument d'entree pour le s-prog +c x et y sont des arguments de sortie pour le s-prog +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + INTEGER klevel + REAL rot( ip1jm,klevel ),x( ip1jmp1,klevel ),y(ip1jm,klevel ) + INTEGER l,ij +c + DO 10 l = 1,klevel +c + DO 1 ij = 2, ip1jm + y(ij,l)=( rot(ij,l) - rot(ij-1,l)) + 1 CONTINUE +c +c ..... correction pour y ( 1,j,l ) ...... +c +c .... y(1,j,l)= y(iip1,j,l) .... + + DO 2 ij = 1, ip1jm, iip1 + y( ij,l ) = y( ij +iim,l ) + 2 CONTINUE +c + DO 4 ij = iip2,ip1jm + x(ij,l)= rot(ij,l)-rot(ij-iip1,l) + 4 CONTINUE + DO 6 ij = 1,iip1 + x( ij ,l ) = 0. + x( ij +ip1jm,l ) = 0. + 6 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/nxgraro2.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgraro2.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgraro2.F (revision 1632) @@ -0,0 +1,68 @@ +! +! $Header$ +! + SUBROUTINE nxgraro2 (klevel,xcov, ycov, lr, grx, gry ) +c +c P.Le Van . +c *********************************************************** +c lr +c calcul de ( nxgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +c +c ...... variables en arguments ....... +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) +c +c ...... variables locales ........ +c + REAL rot(ip1jm,llm) , signe, nugradrs + INTEGER l,ij,iter,lr +c ........................................................ +c +c +c + signe = (-1.)**lr + nugradrs = signe * crot +c + CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 ) + CALL SCOPY ( ip1jm * klevel, ycov, 1, gry, 1 ) +c + CALL rotatf ( klevel, grx, gry, rot ) +c + CALL laplacien_rot ( klevel, rot, rot,grx,gry ) + +c +c ..... Iteration de l'operateur laplacien_rotgam ..... +c + DO iter = 1, lr -2 + CALL laplacien_rotgam ( klevel, rot, rot ) + ENDDO +c +c + CALL filtreg( rot, jjm, klevel, 2,1, .FALSE.,1) + CALL nxgrad ( klevel, rot, grx, gry ) +c + DO l = 1, klevel + DO ij = 1, ip1jm + gry( ij,l ) = gry( ij,l ) * nugradrs + ENDDO + DO ij = 1, ip1jmp1 + grx( ij,l ) = grx( ij,l ) * nugradrs + ENDDO + ENDDO +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/nxgraro2_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgraro2_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgraro2_loc.F (revision 1632) @@ -0,0 +1,142 @@ + SUBROUTINE nxgraro2_loc(klevel,xcov,ycov,lr,grx_out,gry_out) +c +c P.Le Van . +c *********************************************************** +c lr +c calcul de ( nxgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + USE write_Field_p + USE parallel + USE times + USE mod_hallo + USE mod_filtreg_p + USE nxgraro2_mod + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +c +c ...... variables en arguments ....... +c + INTEGER klevel + REAL xcov( ijb_u:ije_u,klevel ), ycov( ijb_v:ije_v,klevel ) + REAL grx_out( ijb_u:ije_u,klevel ),gry_out(ijb_v:ije_v,klevel) +c +c ...... variables locales ........ +c + REAL signe, nugradrs + INTEGER l,ij,iter,lr + Type(Request) :: Request_dissip +c ........................................................ +c + INTEGER :: ijb,ije,jjb,jje + +c +c + signe = (-1.)**lr + nugradrs = signe * crot +c +c CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 ) +c CALL SCOPY ( ip1jm * klevel, ycov, 1, gry, 1 ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + grx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER + call Register_Hallo_u(grx,llm,0,1,1,0,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gry(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c + CALL rotatf_loc ( klevel, grx, gry, rot ) +c call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/))) + +c$OMP BARRIER + call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_rot_loc ( klevel, rot, rot,grx,gry ) +c call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/))) +c +c ..... Iteration de l'operateur laplacien_rotgam ..... +c + DO iter = 1, lr -2 +c$OMP BARRIER + call Register_Hallo_v(rot,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_rotgam_loc( klevel, rot, rot ) + ENDDO + +c call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/))) + +c +c + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p( rot, jjb_v,jje_v, jjb,jje,jjm, + & klevel, 2,1, .FALSE.,1) +c$OMP BARRIER + call Register_Hallo_v(rot,llm,1,0,0,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL nxgrad_loc ( klevel, rot, grx, gry ) + +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + + if(pole_sud) ije=ij_end-iip1 + DO ij = ijb, ije + gry_out( ij,l ) = gry( ij,l ) * nugradrs + ENDDO + + if(pole_sud) ije=ij_end + DO ij = ijb, ije + grx_out( ij,l ) = grx( ij,l ) * nugradrs + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/nxgraro2_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgraro2_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgraro2_mod.F90 (revision 1632) @@ -0,0 +1,39 @@ +MODULE nxgraro2_mod + + REAL,POINTER,SAVE :: grx( :,: ) + REAL,POINTER,SAVE :: gry( :,: ) + REAL,POINTER,SAVE :: rot( :,: ) + +CONTAINS + + SUBROUTINE nxgraro2_allocate + USE bands + USE allocate_field + USE parallel + USE dimensions + IMPLICIT NONE + TYPE(distrib),POINTER :: d + d=>distrib_dissip + + CALL allocate_u(grx,llm,d) + CALL allocate_v(gry,llm,d) + CALL allocate_v(rot,llm,d) + + + END SUBROUTINE nxgraro2_allocate + + SUBROUTINE nxgraro2_switch_dissip(dist) + USE allocate_field + USE bands + USE parallel + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(grx,distrib_dissip,dist) + CALL switch_v(gry,distrib_dissip,dist) + CALL switch_v(rot,distrib_dissip,dist) + + + END SUBROUTINE nxgraro2_switch_dissip + +END MODULE nxgraro2_mod Index: /LMDZ5/trunk/libf/dyn3dmem/nxgraro2_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgraro2_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgraro2_p.F (revision 1632) @@ -0,0 +1,141 @@ + SUBROUTINE nxgraro2_p (klevel,xcov, ycov, lr, grx_out, gry_out ) +c +c P.Le Van . +c *********************************************************** +c lr +c calcul de ( nxgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + USE write_Field_p + USE parallel + USE times + USE mod_hallo + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +c +c ...... variables en arguments ....... +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL,SAVE :: grx( ip1jmp1,llm ), gry( ip1jm,llm ) + REAL grx_out( ip1jmp1,klevel ), gry_out( ip1jm,klevel ) +c +c ...... variables locales ........ +c + REAL,SAVE :: rot(ip1jm,llm) + REAL signe, nugradrs + INTEGER l,ij,iter,lr + Type(Request) :: Request_dissip +c ........................................................ +c + INTEGER :: ijb,ije,jjb,jje + +c +c + signe = (-1.)**lr + nugradrs = signe * crot +c +c CALL SCOPY ( ip1jmp1* klevel, xcov, 1, grx, 1 ) +c CALL SCOPY ( ip1jm * klevel, ycov, 1, gry, 1 ) + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + grx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c$OMP BARRIER + call Register_Hallo(grx,ip1jmp1,llm,0,1,1,0,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gry(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + +c + CALL rotatf_p ( klevel, grx, gry, rot ) +c call write_field3d_p('rot1',reshape(rot,(/iip1,jjm,llm/))) + +c$OMP BARRIER + call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_rot_p ( klevel, rot, rot,grx,gry ) +c call write_field3d_p('rot2',reshape(rot,(/iip1,jjm,llm/))) +c +c ..... Iteration de l'operateur laplacien_rotgam ..... +c + DO iter = 1, lr -2 +c$OMP BARRIER + call Register_Hallo(rot,ip1jm,llm,1,1,1,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL laplacien_rotgam_p ( klevel, rot, rot ) + ENDDO + +c call write_field3d_p('rot3',reshape(rot,(/iip1,jjm,llm/))) + +c +c + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + + CALL filtreg_p( rot, jjb,jje,jjm, klevel, 2,1, .FALSE.,1) +c$OMP BARRIER + call Register_Hallo(rot,ip1jm,llm,1,0,0,1,Request_dissip) + call SendRequest(Request_dissip) +c$OMP BARRIER + call WaitRequest(Request_dissip) +c$OMP BARRIER + + CALL nxgrad_p ( klevel, rot, grx, gry ) + +c + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + + if(pole_sud) ije=ij_end-iip1 + DO ij = ijb, ije + gry_out( ij,l ) = gry( ij,l ) * nugradrs + ENDDO + + if(pole_sud) ije=ij_end + DO ij = ijb, ije + grx_out( ij,l ) = grx( ij,l ) * nugradrs + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/nxgrarot.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgrarot.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgrarot.F (revision 1632) @@ -0,0 +1,55 @@ +! +! $Header$ +! + SUBROUTINE nxgrarot (klevel,xcov, ycov, lr, grx, gry ) +c *********************************************************** +c +c Auteur : P.Le Van +c +c lr +c calcul de ( nXgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + IMPLICIT NONE +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx( ip1jmp1,klevel ), gry( ip1jm,klevel ) +c + REAL rot(ip1jm,llm) + + INTEGER l,ij,iter,lr +c +c +c + CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 ) + CALL SCOPY ( ip1jm*klevel, ycov, 1, gry, 1 ) +c + DO 10 iter = 1,lr + CALL rotat (klevel,grx, gry, rot ) + CALL filtreg( rot, jjm, klevel, 2,1, .false.,2) + CALL nxgrad (klevel,rot, grx, gry ) +c + DO 5 l = 1, klevel + DO 2 ij = 1, ip1jm + gry( ij,l ) = - gry( ij,l ) * crot + 2 CONTINUE + DO 3 ij = 1, ip1jmp1 + grx( ij,l ) = - grx( ij,l ) * crot + 3 CONTINUE + 5 CONTINUE +c + 10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/nxgrarot_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/nxgrarot_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/nxgrarot_p.F (revision 1632) @@ -0,0 +1,101 @@ + SUBROUTINE nxgrarot_p (klevel,xcov, ycov, lr, grx_out, gry_out ) +c *********************************************************** +c +c Auteur : P.Le Van +c +c lr +c calcul de ( nXgrad (rot) ) du vect. v .... +c +c xcov et ycov etant les compos. covariantes de v +c *********************************************************** +c xcov , ycov et lr sont des arguments d'entree pour le s-prog +c grx et gry sont des arguments de sortie pour le s-prog +c +c + USE parallel + USE times + USE write_field_p + IMPLICIT NONE +c +c +#include "dimensions.h" +#include "paramet.h" +#include "comdissipn.h" +#include "logic.h" +c + INTEGER klevel + REAL xcov( ip1jmp1,klevel ), ycov( ip1jm,klevel ) + REAL grx_out( ip1jmp1,klevel ), gry_out( ip1jm,klevel ) + REAL,SAVE :: grx( ip1jmp1,llm ), gry( ip1jm,llm ) + +c + REAL,SAVE :: rot(ip1jm,llm) + + INTEGER l,ij,iter,lr +c + INTEGER ijb,ije,jjb,jje +c +c +c CALL SCOPY ( ip1jmp1*klevel, xcov, 1, grx, 1 ) +c CALL SCOPY ( ip1jm*klevel, ycov, 1, gry, 1 ) +c + ijb=ij_begin + ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + grx(ijb:ije,l)=xcov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + if(pole_sud) ije=ij_end-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + gry(ijb:ije,l)=ycov(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + + DO 10 iter = 1,lr +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(grx,ip1jmp1,llm,0,1) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL rotat_p (klevel,grx, gry, rot ) +c call write_field3d_p('rot',reshape(rot,(/iip1,jjm,llm/))) + + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + CALL filtreg_p( rot,jjb,jje, jjm, klevel, 2,1, .false.,2) + +c$OMP BARRIER +c$OMP MASTER + call suspend_timer(timer_dissip) + call exchange_Hallo(rot,ip1jm,llm,1,0) + call resume_timer(timer_dissip) +c$OMP END MASTER +c$OMP BARRIER + + CALL nxgrad_p (klevel,rot, grx, gry ) +c +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1, klevel + if(pole_sud) ije=ij_end-iip1 + DO 2 ij = ijb, ije + gry_out( ij,l ) = - gry( ij,l ) * crot + 2 CONTINUE + if(pole_sud) ije=ij_end + DO 3 ij = ijb, ije + grx_out( ij,l ) = - grx( ij,l ) * crot + 3 CONTINUE + 5 CONTINUE +c$OMP END DO NOWAIT +c call write_field3d_p('grx',reshape(grx,(/iip1,jjp1,llm/))) +c call write_field3d_p('gry',reshape(gry,(/iip1,jjm,llm/))) +c stop + 10 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/omp_chunk.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/omp_chunk.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/omp_chunk.h (revision 1632) @@ -0,0 +1,1 @@ +#define OMP_CHUNK 5 Index: /LMDZ5/trunk/libf/dyn3dmem/parallel.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/parallel.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/parallel.F90 (revision 1632) @@ -0,0 +1,739 @@ +! +! $Id: parallel.F90 1279 2009-12-10 09:02:56Z fairhead $ +! + module parallel + USE mod_const_mpi + + INTEGER,PARAMETER :: halo_max=3 + + LOGICAL,SAVE :: using_mpi + LOGICAL,SAVE :: using_omp + + integer, save :: mpi_size + integer, save :: mpi_rank + integer, save :: jj_begin + integer, save :: jj_end + integer, save :: jj_nb + integer, save :: ij_begin + integer, save :: ij_end + logical, save :: pole_nord + logical, save :: pole_sud + + integer,save :: jjb_u + integer,save :: jje_u + integer,save :: jjnb_u + integer,save :: jjb_v + integer,save :: jje_v + integer,save :: jjnb_v + + integer,save :: ijb_u + integer,save :: ije_u + integer,save :: ijnb_u + + integer,save :: ijb_v + integer,save :: ije_v + integer,save :: ijnb_v + + + integer, allocatable, save, dimension(:) :: jj_begin_para + integer, allocatable, save, dimension(:) :: jj_end_para + integer, allocatable, save, dimension(:) :: jj_nb_para + integer, save :: OMP_CHUNK + integer, save :: omp_rank + integer, save :: omp_size +!$OMP THREADPRIVATE(omp_rank) + + TYPE distrib + integer :: jj_begin + integer :: jj_end + integer :: jj_nb + integer :: ij_begin + integer :: ij_end + + integer :: jjb_u + integer :: jje_u + integer :: jjnb_u + integer :: jjb_v + integer :: jje_v + integer :: jjnb_v + + integer :: ijb_u + integer :: ije_u + integer :: ijnb_u + + integer :: ijb_v + integer :: ije_v + integer :: ijnb_v + + + integer, pointer :: jj_begin_para(:) => NULL() + integer, pointer :: jj_end_para(:) => NULL() + integer, pointer :: jj_nb_para(:) => NULL() + END TYPE distrib + + INTERFACE ASSIGNMENT (=) + MODULE PROCEDURE copy_distrib + END INTERFACE + TYPE(distrib),SAVE :: current_dist + + contains + + subroutine init_parallel + USE vampir + implicit none +#ifdef CPP_MPI + include 'mpif.h' +#endif +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" + + integer :: ierr + integer :: i,j + integer :: type_size + integer, dimension(3) :: blocklen,type + integer :: comp_id + +#ifdef CPP_OMP + INTEGER :: OMP_GET_NUM_THREADS + EXTERNAL OMP_GET_NUM_THREADS + INTEGER :: OMP_GET_THREAD_NUM + EXTERNAL OMP_GET_THREAD_NUM +#endif + +#ifdef CPP_MPI + using_mpi=.TRUE. +#else + using_mpi=.FALSE. +#endif + + +#ifdef CPP_OMP + using_OMP=.TRUE. +#else + using_OMP=.FALSE. +#endif + + call InitVampir + + IF (using_mpi) THEN +#ifdef CPP_MPI + call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr) + call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr) +#endif + ELSE + mpi_size=1 + mpi_rank=0 + ENDIF + + + allocate(jj_begin_para(0:mpi_size-1)) + allocate(jj_end_para(0:mpi_size-1)) + allocate(jj_nb_para(0:mpi_size-1)) + + do i=0,mpi_size-1 + jj_nb_para(i)=(jjm+1)/mpi_size + if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1 + + if (jj_nb_para(i) <= 2 ) then + + write(lunout,*)"Arret : le nombre de bande de lattitude par process est trop faible (<2)." + write(lunout,*)" ---> diminuez le nombre de CPU ou augmentez la taille en lattitude" + +#ifdef CPP_MPI + IF (using_mpi) call MPI_ABORT(COMM_LMDZ,-1, ierr) +#endif + endif + + enddo + +! jj_nb_para(0)=11 +! jj_nb_para(1)=25 +! jj_nb_para(2)=25 +! jj_nb_para(3)=12 + + j=1 + + do i=0,mpi_size-1 + + jj_begin_para(i)=j + jj_end_para(i)=j+jj_Nb_para(i)-1 + j=j+jj_Nb_para(i) + + enddo + + jj_begin = jj_begin_para(mpi_rank) + jj_end = jj_end_para(mpi_rank) + jj_nb = jj_nb_para(mpi_rank) + + ij_begin=(jj_begin-1)*iip1+1 + ij_end=jj_end*iip1 + + if (mpi_rank.eq.0) then + pole_nord=.TRUE. + else + pole_nord=.FALSE. + endif + + if (mpi_rank.eq.mpi_size-1) then + pole_sud=.TRUE. + else + pole_sud=.FALSE. + endif + + write(lunout,*)"init_parallel: jj_begin",jj_begin + write(lunout,*)"init_parallel: jj_end",jj_end + write(lunout,*)"init_parallel: ij_begin",ij_begin + write(lunout,*)"init_parallel: ij_end",ij_end + jjb_u=MAX(jj_begin-halo_max,1) + jje_u=MIN(jj_end+halo_max,jjp1) + jjnb_u=jje_u-jjb_u+1 + + jjb_v=MAX(jj_begin-halo_max,1) + jje_v=MIN(jj_end+halo_max,jjm) + jjnb_v=jje_v-jjb_v+1 + + ijb_u=MAX(ij_begin-halo_max*iip1,1) + ije_u=MIN(ij_end+halo_max*iip1,ip1jmp1) + ijnb_u=ije_u-ijb_u+1 + + ijb_v=MAX(ij_begin-halo_max*iip1,1) + ije_v=MIN(ij_end+halo_max*iip1,ip1jm) + ijnb_v=ije_v-ijb_v+1 + +!$OMP PARALLEL + +#ifdef CPP_OMP +!$OMP MASTER + omp_size=OMP_GET_NUM_THREADS() +!$OMP END MASTER + omp_rank=OMP_GET_THREAD_NUM() +#else + omp_size=1 + omp_rank=0 +#endif +!$OMP END PARALLEL + CALL create_distrib(jj_nb_para,current_dist) + + end subroutine init_parallel + + SUBROUTINE create_distrib(jj_nb_new,d) + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + + INTEGER,INTENT(IN) :: jj_Nb_New(0:MPI_Size-1) + TYPE(distrib),INTENT(INOUT) :: d + INTEGER :: i + + IF (.NOT. ASSOCIATED(d%jj_nb_para)) ALLOCATE(d%jj_nb_para(0:MPI_Size-1)) + IF (.NOT. ASSOCIATED(d%jj_begin_para)) ALLOCATE(d%jj_begin_para(0:MPI_Size-1)) + IF (.NOT. ASSOCIATED(d%jj_end_para)) ALLOCATE(d%jj_end_para(0:MPI_Size-1)) + + d%jj_Nb_Para=jj_Nb_New + + d%jj_begin_para(0)=1 + d%jj_end_para(0)=d%jj_Nb_Para(0) + + do i=1,mpi_size-1 + + d%jj_begin_para(i)=d%jj_end_para(i-1)+1 + d%jj_end_para(i)=d%jj_begin_para(i)+d%jj_Nb_para(i)-1 + + enddo + + d%jj_begin = d%jj_begin_para(mpi_rank) + d%jj_end = d%jj_end_para(mpi_rank) + d%jj_nb = d%jj_nb_para(mpi_rank) + + d%ij_begin=(d%jj_begin-1)*iip1+1 + d%ij_end=d%jj_end*iip1 + + d%jjb_u=MAX(d%jj_begin-halo_max,1) + d%jje_u=MIN(d%jj_end+halo_max,jjp1) + d%jjnb_u=d%jje_u-d%jjb_u+1 + + d%jjb_v=MAX(d%jj_begin-halo_max,1) + d%jje_v=MIN(d%jj_end+halo_max,jjm) + d%jjnb_v=d%jje_v-d%jjb_v+1 + + d%ijb_u=MAX(d%ij_begin-halo_max*iip1,1) + d%ije_u=MIN(d%ij_end+halo_max*iip1,ip1jmp1) + d%ijnb_u=d%ije_u-d%ijb_u+1 + + d%ijb_v=MAX(d%ij_begin-halo_max*iip1,1) + d%ije_v=MIN(d%ij_end+halo_max*iip1,ip1jm) + d%ijnb_v=d%ije_v-d%ijb_v+1 + + END SUBROUTINE create_distrib + + + SUBROUTINE Set_Distrib(d) + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + TYPE(distrib),INTENT(IN) :: d + + jj_begin = d%jj_begin + jj_end = d%jj_end + jj_nb = d%jj_nb + ij_begin = d%ij_begin + ij_end = d%ij_end + + jjb_u = d%jjb_u + jje_u = d%jje_u + jjnb_u = d%jjnb_u + jjb_v = d%jjb_v + jje_v = d%jje_v + jjnb_v = d%jjnb_v + + ijb_u = d%ijb_u + ije_u = d%ije_u + ijnb_u = d%ijnb_u + + ijb_v = d%ijb_v + ije_v = d%ije_v + ijnb_v = d%ijnb_v + + + jj_begin_para(:) = d%jj_begin_para(:) + jj_end_para(:) = d%jj_end_para(:) + jj_nb_para(:) = d%jj_nb_para(:) + current_dist=d + + END SUBROUTINE Set_Distrib + + SUBROUTINE copy_distrib(dist,new_dist) + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + TYPE(distrib),INTENT(INOUT) :: dist + TYPE(distrib),INTENT(IN) :: new_dist + + dist%jj_begin = new_dist%jj_begin + dist%jj_end = new_dist%jj_end + dist%jj_nb = new_dist%jj_nb + dist%ij_begin = new_dist%ij_begin + dist%ij_end = new_dist%ij_end + + dist%jjb_u = new_dist%jjb_u + dist%jje_u = new_dist%jje_u + dist%jjnb_u = new_dist%jjnb_u + dist%jjb_v = new_dist%jjb_v + dist%jje_v = new_dist%jje_v + dist%jjnb_v = new_dist%jjnb_v + + dist%ijb_u = new_dist%ijb_u + dist%ije_u = new_dist%ije_u + dist%ijnb_u = new_dist%ijnb_u + + dist%ijb_v = new_dist%ijb_v + dist%ije_v = new_dist%ije_v + dist%ijnb_v = new_dist%ijnb_v + + + dist%jj_begin_para(:) = new_dist%jj_begin_para(:) + dist%jj_end_para(:) = new_dist%jj_end_para(:) + dist%jj_nb_para(:) = new_dist%jj_nb_para(:) + + END SUBROUTINE copy_distrib + + + SUBROUTINE get_current_distrib(d) + IMPLICIT NONE + + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + TYPE(distrib),INTENT(OUT) :: d + + d=current_dist + + END SUBROUTINE get_current_distrib + + subroutine Finalize_parallel +#ifdef CPP_COUPLE + use mod_prism_proto +#endif +#ifdef CPP_EARTH +! Ehouarn: surface_data module is in 'phylmd' ... + use surface_data, only : type_ocean + implicit none +#else + implicit none +! without the surface_data module, we declare (and set) a dummy 'type_ocean' + character(len=6),parameter :: type_ocean="dummy" +#endif +! #endif of #ifdef CPP_EARTH + + include "dimensions.h" + include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + + integer :: ierr + integer :: i + deallocate(jj_begin_para) + deallocate(jj_end_para) + deallocate(jj_nb_para) + + if (type_ocean == 'couple') then +#ifdef CPP_COUPLE + call prism_terminate_proto(ierr) + IF (ierr .ne. PRISM_Ok) THEN + call abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1) + endif +#endif + else +#ifdef CPP_MPI + IF (using_mpi) call MPI_FINALIZE(ierr) +#endif + end if + + end subroutine Finalize_parallel + + subroutine Pack_Data(Field,ij,ll,row,Buffer) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + integer, intent(in) :: ij,ll,row + real,dimension(ij,ll),intent(in) ::Field + real,dimension(ll*iip1*row), intent(out) :: Buffer + + integer :: Pos + integer :: i,l + + Pos=0 + do l=1,ll + do i=1,row*iip1 + Pos=Pos+1 + Buffer(Pos)=Field(i,l) + enddo + enddo + + end subroutine Pack_data + + subroutine Unpack_Data(Field,ij,ll,row,Buffer) + implicit none + +#include "dimensions.h" +#include "paramet.h" + + integer, intent(in) :: ij,ll,row + real,dimension(ij,ll),intent(out) ::Field + real,dimension(ll*iip1*row), intent(in) :: Buffer + + integer :: Pos + integer :: i,l + + Pos=0 + + do l=1,ll + do i=1,row*iip1 + Pos=Pos+1 + Field(i,l)=Buffer(Pos) + enddo + enddo + + end subroutine UnPack_data + + + SUBROUTINE barrier + IMPLICIT NONE +#ifdef CPP_MPI + INCLUDE 'mpif.h' +#endif + INTEGER :: ierr + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + + END SUBROUTINE barrier + + + subroutine exchange_hallo(Field,ij,ll,up,down) + USE Vampir + implicit none +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: up,down + + INTEGER :: ierr + LOGICAL :: SendUp,SendDown + LOGICAL :: RecvUp,RecvDown + INTEGER, DIMENSION(4) :: Request +#ifdef CPP_MPI + INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status +#else + INTEGER, DIMENSION(1,4) :: Status +#endif + INTEGER :: NbRequest + REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down + REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down + INTEGER :: Buffer_size + + IF (using_mpi) THEN + + CALL barrier + + call VTb(VThallo) + + SendUp=.TRUE. + SendDown=.TRUE. + RecvUp=.TRUE. + RecvDown=.TRUE. + + IF (pole_nord) THEN + SendUp=.FALSE. + RecvUp=.FALSE. + ENDIF + + IF (pole_sud) THEN + SendDown=.FALSE. + RecvDown=.FALSE. + ENDIF + + if (up.eq.0) then + SendDown=.FALSE. + RecvUp=.FALSE. + endif + + if (down.eq.0) then + SendUp=.FALSE. + RecvDown=.FALSE. + endif + + NbRequest=0 + + IF (SendUp) THEN + NbRequest=NbRequest+1 + buffer_size=down*iip1*ll + allocate(Buffer_Send_up(Buffer_size)) + call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up) +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + ENDIF + + IF (SendDown) THEN + NbRequest=NbRequest+1 + + buffer_size=up*iip1*ll + allocate(Buffer_Send_down(Buffer_size)) + call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down) + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + ENDIF + + + IF (RecvUp) THEN + NbRequest=NbRequest+1 + buffer_size=up*iip1*ll + allocate(Buffer_recv_up(Buffer_size)) + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + + + ENDIF + + IF (RecvDown) THEN + NbRequest=NbRequest+1 + buffer_size=down*iip1*ll + allocate(Buffer_recv_down(Buffer_size)) + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1, & + COMM_LMDZ,Request(NbRequest),ierr) +#endif +!$OMP END CRITICAL (MPI) + + ENDIF + +#ifdef CPP_MPI + if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr) +#endif + IF (RecvUp) call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up) + IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down) + + call VTe(VThallo) + call barrier + + ENDIF ! using_mpi + + RETURN + + end subroutine exchange_Hallo + + + subroutine Gather_Field(Field,ij,ll,rank) + implicit none +#include "dimensions.h" +#include "paramet.h" +#include "iniprint.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll,rank + REAL, dimension(ij,ll) :: Field + REAL, dimension(:),allocatable :: Buffer_send + REAL, dimension(:),allocatable :: Buffer_Recv + INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ + INTEGER :: ierr + INTEGER ::i + + IF (using_mpi) THEN + + if (ij==ip1jmp1) then + allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1))) + call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send) + else if (ij==ip1jm) then + allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1))) + call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send) + else + write(lunout,*)ij + stop 'erreur dans Gather_Field' + endif + + if (MPI_Rank==rank) then + allocate(Buffer_Recv(ij*ll)) + +!CDIR NOVECTOR + do i=0,MPI_Size-1 + + if (ij==ip1jmp1) then + Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1 + else if (ij==ip1jm) then + Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1 + else + stop 'erreur dans Gather_Field' + endif + + if (i==0) then + displ(i)=0 + else + displ(i)=displ(i-1)+Recv_count(i-1) + endif + + enddo + + endif + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8, & + Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + + if (MPI_Rank==rank) then + + if (ij==ip1jmp1) then + do i=0,MPI_Size-1 + call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, & + jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1)) + enddo + else if (ij==ip1jm) then + do i=0,MPI_Size-1 + call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll, & + min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1)) + enddo + endif + endif + ENDIF ! using_mpi + + end subroutine Gather_Field + + + subroutine AllGather_Field(Field,ij,ll) + implicit none +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: ierr + + IF (using_mpi) THEN + call Gather_Field(Field,ij,ll,0) +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + ENDIF + + end subroutine AllGather_Field + + subroutine Broadcast_Field(Field,ij,ll,rank) + implicit none +#include "dimensions.h" +#include "paramet.h" +#ifdef CPP_MPI + include 'mpif.h' +#endif + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: rank + INTEGER :: ierr + + IF (using_mpi) THEN + +!$OMP CRITICAL (MPI) +#ifdef CPP_MPI + call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr) +#endif +!$OMP END CRITICAL (MPI) + + ENDIF + end subroutine Broadcast_Field + + + /* + Subroutine verif_hallo(Field,ij,ll,up,down) + implicit none +#include "dimensions.h" +#include "paramet.h" + include 'mpif.h' + + INTEGER :: ij,ll + REAL, dimension(ij,ll) :: Field + INTEGER :: up,down + + REAL,dimension(ij,ll): NewField + + NewField=0 + + ijb=ij_begin + ije=ij_end + if (pole_nord) + NewField(ij_be +*/ + end module parallel Index: /LMDZ5/trunk/libf/dyn3dmem/paramet.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/paramet.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/paramet.h (revision 1632) @@ -0,0 +1,29 @@ +! +! $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 'paramet.h' + + INTEGER iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1 + INTEGER kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm + INTEGER ijmllm,mvar + INTEGER jcfil,jcfllm + + PARAMETER( iip1= iim+1-1/iim,iip2=iim+2,iip3=iim+3 & + & ,jjp1=jjm+1-1/jjm) + PARAMETER( llmp1 = llm+1, llmp2 = llm+2, llmm1 = llm-1 ) + PARAMETER( kftd = iim/2 -ndm ) + PARAMETER( ip1jm = iip1*jjm, ip1jmp1= iip1*jjp1 ) + PARAMETER( ip1jmi1= ip1jm - iip1 ) + PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm ) + PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm ) + PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm ) + +!----------------------------------------------------------------------- Index: /LMDZ5/trunk/libf/dyn3dmem/pbar.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/pbar.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/pbar.F (revision 1632) @@ -0,0 +1,124 @@ +! +! $Header$ +! + SUBROUTINE pbar ( pext, pbarx, pbary, pbarxy ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************** +c calcul des moyennes en x et en y de (pression au sol*aire variable) .. +c ********************************************************************* +c +c pext est un argum. d'entree pour le s-pg .. +c pbarx,pbary et pbarxy sont des argum. de sortie pour le s-pg .. +c +c Methode: +c -------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c +c On a : +c +c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + +c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) +c localise au point ... Z (i,j) ... +c +c +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" + +#include "comgeom.h" + + REAL pext( ip1jmp1 ), pbarx ( ip1jmp1 ) + REAL pbary( ip1jm ), pbarxy( ip1jm ) + + INTEGER ij + + + + DO 1 ij = 1, ip1jmp1 - 1 + pbarx( ij ) = pext(ij) * alpha1p2(ij) + pext(ij+1)*alpha3p4(ij+1) + 1 CONTINUE + +c .... correction pour pbarx( iip1,j) ..... + +c ... pbarx(iip1,j)= pbarx(1,j) ... +CDIR$ IVDEP + DO 2 ij = iip1, ip1jmp1, iip1 + pbarx( ij ) = pbarx( ij - iim ) + 2 CONTINUE + + + DO 3 ij = 1,ip1jm + pbary( ij ) = pext( ij ) * alpha2p3( ij ) + + * pext( ij+iip1 ) * alpha1p4( ij+iip1 ) + 3 CONTINUE + + + DO 5 ij = 1, ip1jm - 1 + pbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + + * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) + 5 CONTINUE + + +c .... correction pour pbarxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + pbarxy( ij ) = pbarxy( ij - iim ) + 7 CONTINUE + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/pentes_ini.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/pentes_ini.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/pentes_ini.F (revision 1632) @@ -0,0 +1,474 @@ +! +! $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 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/dyn3dmem/ppm3d.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/ppm3d.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/ppm3d.F (revision 1632) @@ -0,0 +1,2001 @@ +! +! $Id: ppm3d.F 1299 2010-01-20 14:27:21Z fairhead $ +! + +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/dyn3dmem/prather.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/prather.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/prather.F (revision 1632) @@ -0,0 +1,359 @@ +! +! $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 + + 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/dyn3dmem/pres2lev.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/pres2lev.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/pres2lev.F90 (revision 1632) @@ -0,0 +1,74 @@ +! $Id: pres2lev.F 1179 2009-06-11 14:18:47Z jghattas $ +! +!****************************************************** +SUBROUTINE pres2lev(varo,varn,lmo,lmn,po,pn,ni,nj,ok_invertp) +! +! interpolation lineaire pour passer +! a une nouvelle discretisation verticale pour +! les variables de GCM +! Francois Forget (01/1995) +! MOdif remy roca 12/97 pour passer de pres2sig +! Modif F.Codron 07/08 po en 3D +!********************************************************** + + IMPLICIT NONE + +! Declarations: +! ============== +! +! ARGUMENTS +! """"""""" + LOGICAL, INTENT(IN) :: ok_invertp + INTEGER, INTENT(IN) :: lmo ! dimensions ancienne couches + INTEGER, INTENT(IN) :: lmn ! dimensions nouvelle couches + + REAL, INTENT(IN) :: po(ni*nj,lmo) ! niveau de pression ancienne grille + REAL, INTENT(IN) :: pn(ni*nj,lmn) ! niveau de pression nouvelle grille + + INTEGER, INTENT(IN) :: ni,nj ! nombre de point horizontal + + REAL, INTENT(IN) :: varo(ni*nj,lmo) ! var dans l'ancienne grille + REAL, INTENT(OUT) :: varn(ni*nj,lmn) ! var dans la nouvelle grille + + REAL :: zvaro(ni*nj,lmo),zpo(ni*nj,lmo) + +! Autres variables +! """""""""""""""" + INTEGER :: ln ,lo, k + REAL :: coef + + +! Inversion de l'ordre des niveaux verticaux + IF (ok_invertp) THEN + DO lo=1,lmo + DO k=1,ni*nj + zpo(k,lo)=po(k,lmo+1-lo) + zvaro(k,lo)=varo(k,lmo+1-lo) + ENDDO + ENDDO + ELSE + DO lo=1,lmo + DO k=1,ni*nj + zpo(k,lo)=po(k,lo) + zvaro(k,lo)=varo(k,lo) + ENDDO + ENDDO + ENDIF + + DO ln=1,lmn + DO lo=1,lmo-1 + DO k=1,ni*nj + IF (pn(k,ln) >= zpo(k,1) ) THEN + varn(k,ln) = varo(k,1) + ELSE IF (pn(k,ln) <= zpo(k,lmo)) THEN + varn(k,ln) = zvaro(k,lmo) + ELSE IF ( pn(k,ln) <= zpo(k,lo) .AND. pn(k,ln) > zpo(k,lo+1) ) THEN + coef = (pn(k,ln)-zpo(k,lo)) / (zpo(k,lo+1)-zpo(k,lo)) + varn(k,ln) = zvaro(k,lo) + coef*(zvaro(k,lo+1)-zvaro(k,lo)) + ENDIF + + ENDDO + ENDDO + ENDDO + +END SUBROUTINE pres2lev Index: /LMDZ5/trunk/libf/dyn3dmem/pression.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/pression.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/pression.F (revision 1632) @@ -0,0 +1,32 @@ +! +! $Header$ +! + SUBROUTINE pression( ngrid, ap, bp, ps, p ) +c + +c Auteurs : P. Le Van , Fr.Hourdin . + +c ************************************************************************ +c Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du +c sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) +c couches , avec p(ij,llm +1) = 0. et p(ij,1) = ps(ij) . +c ************************************************************************ +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c + INTEGER ngrid + INTEGER l,ij + + REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) + + DO l = 1, llmp1 + DO ij = 1, ngrid + p(ij,l) = ap(l) + bp(l) * ps(ij) + ENDDO + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/pression_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/pression_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/pression_loc.F (revision 1632) @@ -0,0 +1,41 @@ + SUBROUTINE pression_loc( ngrid, ap, bp, ps, p ) + USE parallel +c + +c Auteurs : P. Le Van , Fr.Hourdin . + +c ************************************************************************ +c Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du +c sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) +c couches , avec p(ij,llm +1) = 0. et p(ij,1) = ps(ij) . +c ************************************************************************ +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c + INTEGER ngrid + INTEGER l,ij + + REAL ap( llmp1 ), bp( llmp1 ), ps( ijb_u:ije_u ) + REAL p( ijb_u:ije_u,llmp1 ) + + INTEGER ijb,ije + + + ijb=ij_begin-iip1 + ije=ij_end+2*iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llmp1 + DO ij = ijb, ije + p(ij,l) = ap(l) + bp(l) * ps(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/pression_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/pression_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/pression_p.F (revision 1632) @@ -0,0 +1,40 @@ + SUBROUTINE pression_p( ngrid, ap, bp, ps, p ) + USE parallel +c + +c Auteurs : P. Le Van , Fr.Hourdin . + +c ************************************************************************ +c Calcule la pression p(l) aux differents niveaux l = 1 ( niveau du +c sol) a l = llm +1 ,ces niveaux correspondant aux interfaces des (llm) +c couches , avec p(ij,llm +1) = 0. et p(ij,1) = ps(ij) . +c ************************************************************************ +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +c + INTEGER ngrid + INTEGER l,ij + + REAL ap( llmp1 ), bp( llmp1 ), ps( ngrid ), p( ngrid,llmp1 ) + + INTEGER ijb,ije + + + ijb=ij_begin-iip1 + ije=ij_end+2*iip1 + + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llmp1 + DO ij = ijb, ije + p(ij,l) = ap(l) + bp(l) * ps(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/profvert.def =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/profvert.def (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/profvert.def (revision 1632) @@ -0,0 +1,23 @@ +! +! $Header$ +! +nom_courbes=F +titre=/home/hourdin/LMDZ4/libf/dyn3d +xinf=0. +xsup=669. +yinf=6.5 +ysup=10.5 +axtxtx=sols +axtxty=pressure (mb) +pathcham=. +lstyles=1 9999 +linewidth=.2 +lcolors=1 9999 +frwidth=.5 +repery0=T +txtheight=2.5 +freecoord=/d2/hourdin/Ames/saison.def + +determination du champ physique +xlength=195. +ylength=105. Index: /LMDZ5/trunk/libf/dyn3dmem/psextbar.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/psextbar.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/psextbar.F (revision 1632) @@ -0,0 +1,107 @@ +! +! $Header$ +! + SUBROUTINE psextbar ( ps, psexbarxy ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ********************************************************************** +c calcul des moyennes en x et en y de (pression au sol*aire variable) .. +c ********************************************************************** +c +c ps est un argum. d'entree pour le s-pg .. +c psexbarxy est un argum. de sortie pour le s-pg .. +c +c Methode: +c -------- +c +c A chaque point scalaire P (i,j) est affecte 4 coefficients d'aires +c alpha1(i,j) calcule au point ( i+1/4,j-1/4 ) +c alpha2(i,j) calcule au point ( i+1/4,j+1/4 ) +c alpha3(i,j) calcule au point ( i-1/4,j+1/4 ) +c alpha4(i,j) calcule au point ( i-1/4,j-1/4 ) +c +c Avec alpha1(i,j) = aire(i+1/4,j-1/4)/ aire(i,j) +c +c N.B . Pour plus de details, voir s-pg ... iniconst ... +c +c +c +c alpha4 . . alpha1 . alpha4 +c (i,j) (i,j) (i+1,j) +c +c P . U . . P +c (i,j) (i,j) (i+1,j) +c +c alpha3 . . alpha2 .alpha3 +c (i,j) (i,j) (i+1,j) +c +c V . Z . . V +c (i,j) +c +c alpha4 . . alpha1 .alpha4 +c (i,j+1) (i,j+1) (i+1,j+1) +c +c P . U . . P +c (i,j+1) (i+1,j+1) +c +c +c +c +c On a : +c +c pbarx(i,j) = Pext(i ,j) * ( alpha1(i ,j) + alpha2(i,j)) + +c Pext(i+1,j) * ( alpha3(i+1,j) + alpha4(i+1,j) ) +c localise au point ... U (i,j) ... +c +c pbary(i,j) = Pext(i,j ) * ( alpha2(i,j ) + alpha3(i,j ) + +c Pext(i,j+1) * ( alpha1(i,j+1) + alpha4(i,j+1) +c localise au point ... V (i,j) ... +c +c pbarxy(i,j)= Pext(i,j) *alpha2(i,j) + Pext(i+1,j) *alpha3(i+1,j) + +c Pext(i,j+1)*alpha1(i,j+1)+ Pext(i+1,j+1)*alpha4(i+1,j+1) +c localise au point ... Z (i,j) ... +c +c +c +c======================================================================= + + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" + + REAL ps( ip1jmp1 ), psexbarxy ( ip1jm ), pext( ip1jmp1 ) + + INTEGER l, ij +c + + DO ij = 1, ip1jmp1 + pext(ij) = ps(ij) * aire(ij) + ENDDO + + + DO 5 ij = 1, ip1jm - 1 + psexbarxy( ij ) = pext(ij)*alpha2(ij) + pext(ij+1)*alpha3(ij+1) + + * pext(ij+iip1)*alpha1(ij+iip1) + pext(ij+iip2)*alpha4(ij+iip2) + 5 CONTINUE + + +c .... correction pour psexbarxy( iip1,j ) ........ + +CDIR$ IVDEP + + DO 7 ij = iip1, ip1jm, iip1 + psexbarxy( ij ) = psexbarxy( ij - iim ) + 7 CONTINUE + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/q_sat.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/q_sat.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/q_sat.F (revision 1632) @@ -0,0 +1,72 @@ +! +! $Header$ +! +c +c + + subroutine q_sat(np,temp,pres,qsat) +c + IMPLICIT none +c====================================================================== +c Autheur(s): Z.X. Li (LMD/CNRS) +c reecriture vectorisee par F. Hourdin. +c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.) +c====================================================================== +c Arguments: +c kelvin---input-R: temperature en Kelvin +c millibar--input-R: pression en mb +c +c q_sat----output-R: vapeur d'eau saturante en kg/kg +c====================================================================== +c + integer np + REAL temp(np),pres(np),qsat(np) +c + REAL r2es + PARAMETER (r2es=611.14 *18.0153/28.9644) +c + REAL r3les, r3ies, r3es + PARAMETER (R3LES=17.269) + PARAMETER (R3IES=21.875) +c + REAL r4les, r4ies, r4es + PARAMETER (R4LES=35.86) + PARAMETER (R4IES=7.66) +c + REAL rtt + PARAMETER (rtt=273.16) +c + REAL retv + PARAMETER (retv=28.9644/18.0153 - 1.0) + + real zqsat + integer ip +c +C ------------------------------------------------------------------ +c +c + + do ip=1,np + +c write(*,*)'kelvin,millibar=',kelvin,millibar +c write(*,*)'temp,pres=',temp(ip),pres(ip) +c + IF (temp(ip) .LE. rtt) THEN + r3es = r3ies + r4es = r4ies + ELSE + r3es = r3les + r4es = r4les + ENDIF +c + zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es)) + zqsat=MIN(0.5,ZQSAT) + zqsat=zqsat/(1.-retv *zqsat) +c + qsat(ip)= zqsat +c write(*,*)'qsat=',qsat(ip) + + enddo +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/qminimum_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/qminimum_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/qminimum_loc.F (revision 1632) @@ -0,0 +1,107 @@ + SUBROUTINE qminimum_loc( q,nq,deltap ) + USE parallel + IMPLICIT none +c +c -- Objet : Traiter les valeurs trop petites (meme negatives) +c pour l'eau vapeur et l'eau liquide +c +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +c + INTEGER nq + REAL q(ijb_u:ije_u,llm,nq), deltap(ijb_u:ije_u,llm) +c + INTEGER iq_vap, iq_liq + PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur + PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide + REAL seuil_vap, seuil_liq + PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur + PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide +c +c NB. ....( Il est souhaitable mais non obligatoire que les valeurs des +c parametres seuil_vap, seuil_liq soient pareilles a celles +c qui sont utilisees dans la routine ADDFI ) +c ................................................................. +c + INTEGER i, k, iq + REAL zx_defau, zx_abc, zx_pump(ijb_u:ije_u), pompe +c + REAL SSUM + EXTERNAL SSUM +c + INTEGER imprim + SAVE imprim + DATA imprim /0/ +c$OMP THREADPRIVATE(imprim) + INTEGER ijb,ije + INTEGER Index_pump(ij_end-ij_begin+1) + INTEGER nb_pump +c +c Quand l'eau liquide est trop petite (ou negative), on prend +c l'eau vapeur de la meme couche et la convertit en eau liquide +c (sans changer la temperature !) +c + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 1000 k = 1, llm + DO 1040 i = ijb, ije + if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then + q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq + q(i,k,iq_liq) = seuil_liq + endif + 1040 CONTINUE + 1000 CONTINUE +c$OMP END DO NOWAIT +c$OMP BARRIER +c ---> SYNCHRO OPENMP ICI + +c +c Quand l'eau vapeur est trop faible (ou negative), on complete +c le defaut en prennant de l'eau vapeur de la couche au-dessous. +c + iq = iq_vap +c + DO k = llm, 2, -1 +ccc zx_abc = dpres(k) / dpres(k-1) +c$OMP DO SCHEDULE(STATIC) + DO i = ijb, ije + if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then + q(i,k-1,iq) = q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) * + & deltap(i,k) / deltap(i,k-1) + q(i,k,iq) = seuil_vap + endif + ENDDO +c$OMP END DO NOWAIT + ENDDO +c$OMP BARRIER +c +c Quand il s'agit de la premiere couche au-dessus du sol, on +c doit imprimer un message d'avertissement (saturation possible). +c + nb_pump=0 +c$OMP DO SCHEDULE(STATIC) + DO i = ijb, ije + zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) ) + q(i,1,iq) = AMAX1( q(i,1,iq), seuil_vap ) + IF (zx_pump(i) > 0.0) THEN + nb_pump = nb_pump+1 + Index_pump(nb_pump)=i + ENDIF + ENDDO +c$OMP END DO +! pompe = SSUM(ije-ijb+1,zx_pump(ijb),1) + + IF (imprim.LE.100 .AND. nb_pump .GT. 0 ) THEN + PRINT *, 'ATT!:on pompe de l eau au sol' + DO i = 1, nb_pump + imprim = imprim + 1 + PRINT*,' en ',index_pump(i),zx_pump(index_pump(i)) + ENDDO + ENDIF +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/qminimum_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/qminimum_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/qminimum_p.F (revision 1632) @@ -0,0 +1,107 @@ + SUBROUTINE qminimum_p( q,nq,deltap ) + USE parallel + IMPLICIT none +c +c -- Objet : Traiter les valeurs trop petites (meme negatives) +c pour l'eau vapeur et l'eau liquide +c +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" +c + INTEGER nq + REAL q(ip1jmp1,llm,nq), deltap(ip1jmp1,llm) +c + INTEGER iq_vap, iq_liq + PARAMETER ( iq_vap = 1 ) ! indice pour l'eau vapeur + PARAMETER ( iq_liq = 2 ) ! indice pour l'eau liquide + REAL seuil_vap, seuil_liq + PARAMETER ( seuil_vap = 1.0e-10 ) ! seuil pour l'eau vapeur + PARAMETER ( seuil_liq = 1.0e-11 ) ! seuil pour l'eau liquide +c +c NB. ....( Il est souhaitable mais non obligatoire que les valeurs des +c parametres seuil_vap, seuil_liq soient pareilles a celles +c qui sont utilisees dans la routine ADDFI ) +c ................................................................. +c + INTEGER i, k, iq + REAL zx_defau, zx_abc, zx_pump(ip1jmp1), pompe +c + REAL SSUM + EXTERNAL SSUM +c + INTEGER imprim + SAVE imprim + DATA imprim /0/ +c$OMP THREADPRIVATE(imprim) + INTEGER ijb,ije + INTEGER Index_pump(ip1jmp1) + INTEGER nb_pump +c +c Quand l'eau liquide est trop petite (ou negative), on prend +c l'eau vapeur de la meme couche et la convertit en eau liquide +c (sans changer la temperature !) +c + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 1000 k = 1, llm + DO 1040 i = ijb, ije + if (seuil_liq - q(i,k,iq_liq) .gt. 0.d0 ) then + q(i,k,iq_vap) = q(i,k,iq_vap) + q(i,k,iq_liq) - seuil_liq + q(i,k,iq_liq) = seuil_liq + endif + 1040 CONTINUE + 1000 CONTINUE +c$OMP END DO NOWAIT +c$OMP BARRIER +c ---> SYNCHRO OPENMP ICI + +c +c Quand l'eau vapeur est trop faible (ou negative), on complete +c le defaut en prennant de l'eau vapeur de la couche au-dessous. +c + iq = iq_vap +c + DO k = llm, 2, -1 +ccc zx_abc = dpres(k) / dpres(k-1) +c$OMP DO SCHEDULE(STATIC) + DO i = ijb, ije + if ( seuil_vap - q(i,k,iq) .gt. 0.d0 ) then + q(i,k-1,iq) = q(i,k-1,iq) - ( seuil_vap - q(i,k,iq) ) * + & deltap(i,k) / deltap(i,k-1) + q(i,k,iq) = seuil_vap + endif + ENDDO +c$OMP END DO NOWAIT + ENDDO +c$OMP BARRIER +c +c Quand il s'agit de la premiere couche au-dessus du sol, on +c doit imprimer un message d'avertissement (saturation possible). +c + nb_pump=0 +c$OMP DO SCHEDULE(STATIC) + DO i = ijb, ije + zx_pump(i) = AMAX1( 0.0, seuil_vap - q(i,1,iq) ) + q(i,1,iq) = AMAX1( q(i,1,iq), seuil_vap ) + IF (zx_pump(i) > 0.0) THEN + nb_pump = nb_pump+1 + Index_pump(nb_pump)=i + ENDIF + ENDDO +c$OMP END DO +! pompe = SSUM(ije-ijb+1,zx_pump(ijb),1) + + IF (imprim.LE.100 .AND. nb_pump .GT. 0 ) THEN + PRINT *, 'ATT!:on pompe de l eau au sol' + DO i = 1, nb_pump + imprim = imprim + 1 + PRINT*,' en ',index_pump(i),zx_pump(index_pump(i)) + ENDDO + ENDIF +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/ran1.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/ran1.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/ran1.F (revision 1632) @@ -0,0 +1,34 @@ +! +! $Id: ran1.F 1299 2010-01-20 14:27:21Z fairhead $ +! + FUNCTION RAN1(IDUM) + DIMENSION R(97) + save r + save iff,ix1,ix2,ix3 + PARAMETER (M1=259200,IA1=7141,IC1=54773,RM1=3.8580247E-6) + PARAMETER (M2=134456,IA2=8121,IC2=28411,RM2=7.4373773E-6) + PARAMETER (M3=243000,IA3=4561,IC3=51349) + DATA IFF /0/ + IF (IDUM.LT.0.OR.IFF.EQ.0) THEN + IFF=1 + IX1=MOD(IC1-IDUM,M1) + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IX1,M2) + IX1=MOD(IA1*IX1+IC1,M1) + IX3=MOD(IX1,M3) + DO 11 J=1,97 + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IA2*IX2+IC2,M2) + R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1 +11 CONTINUE + IDUM=1 + ENDIF + IX1=MOD(IA1*IX1+IC1,M1) + IX2=MOD(IA2*IX2+IC2,M2) + IX3=MOD(IA3*IX3+IC3,M3) + J=1+(97*IX3)/M3 + IF(J.GT.97.OR.J.LT.1)PAUSE + RAN1=R(J) + R(J)=(REAL(IX1)+REAL(IX2)*RM2)*RM1 + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/rotat.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/rotat.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/rotat.F (revision 1632) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE rotat (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + +ccc CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) + + DO l = 1, klevel + DO ij = 1, ip1jm + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/rotat_nfil.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/rotat_nfil.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/rotat_nfil.F (revision 1632) @@ -0,0 +1,49 @@ +! +! $Header$ +! + SUBROUTINE rotat_nfil (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. Calcule le rotationnel non filtre , +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/rotat_nfil_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/rotat_nfil_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/rotat_nfil_loc.F (revision 1632) @@ -0,0 +1,52 @@ + SUBROUTINE rotat_nfil_loc (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. Calcule le rotationnel non filtre , +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ijb_v:ije_v,klevel ) + REAL x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij + INTEGER :: ijb,ije +c +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/rotat_nfil_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/rotat_nfil_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/rotat_nfil_p.F (revision 1632) @@ -0,0 +1,52 @@ + SUBROUTINE rotat_nfil_p (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. Calcule le rotationnel non filtre , +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij + INTEGER :: ijb,ije +c +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/rotat_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/rotat_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/rotat_p.F (revision 1632) @@ -0,0 +1,63 @@ + SUBROUTINE rotat_p (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij + INTEGER :: ijb,ije +c +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE +c$OMP END DO NOWAIT +ccc CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/rotatf.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/rotatf.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/rotatf.F (revision 1632) @@ -0,0 +1,58 @@ +! +! $Header$ +! + SUBROUTINE rotatf (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij +c +c + DO 10 l = 1,klevel +c + DO ij = 1, ip1jm - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE + + CALL filtreg( rot, jjm, klevel, 2, 2, .FALSE., 1 ) + + DO l = 1, klevel + DO ij = 1, ip1jm + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/rotatf_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/rotatf_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/rotatf_loc.F (revision 1632) @@ -0,0 +1,69 @@ + SUBROUTINE rotatf_loc (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + USE parallel + USE mod_filtreg_p + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ijb_v:ije_v,klevel ) + REAL x( ijb_u:ije_u,klevel ), y( ijb_v:ije_v,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE +c$OMP END DO NOWAIT + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + CALL filtreg_p( rot, jjb_v, jje_v,jjb,jje,jjm, + & klevel, 2, 2, .FALSE., 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/rotatf_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/rotatf_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/rotatf_p.F (revision 1632) @@ -0,0 +1,67 @@ + SUBROUTINE rotatf_p (klevel, x, y, rot ) +c +c Auteur : P.Le Van +c************************************************************** +c. calcule le rotationnel +c a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ... +c******************************************************************** +c klevel, x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +c +c ..... variables en arguments ...... +c + INTEGER klevel + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) +c +c ... variables locales ... +c + INTEGER l, ij + INTEGER :: ijb,ije,jjb,jje +c +c + ijb=ij_begin + ije=ij_end + if(pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1,klevel +c + DO ij = ijb, ije - 1 + rot( ij,l ) = y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) + ENDDO +c +c .... correction pour rot( iip1,j,l) .... +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim,l ) + ENDDO +c + 10 CONTINUE +c$OMP END DO NOWAIT + jjb=jj_begin + jje=jj_end + if (pole_sud) jje=jj_end-1 + CALL filtreg_p( rot, jjb,jje,jjm, klevel, 2, 2, .FALSE., 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, klevel + DO ij = ijb, ije + rot(ij,l) = rot(ij,l) * unsairez(ij) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c +c + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/rotatst.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/rotatst.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/rotatst.F (revision 1632) @@ -0,0 +1,43 @@ +! +! $Header$ +! + SUBROUTINE rotatst (klevel,x, y, rot ) +c +c P. Le Van +c +c ***************************************************************** +c .. calcule le rotationnel a tous les niveaux d'1 vecteur de comp. x et y .. +c x et y etant des composantes covariantes ..... +c ***************************************************************** +c x et y sont des arguments d'entree pour le s-prog +c rot est un argument de sortie pour le s-prog +c + IMPLICIT NONE +c + INTEGER klevel +#include "dimensions.h" +#include "paramet.h" + + REAL rot( ip1jm,klevel ) + REAL x( ip1jmp1,klevel ), y( ip1jm,klevel ) + INTEGER l, ij +c +c + DO 5 l = 1,klevel +c + DO 1 ij = 1, ip1jm - 1 + rot( ij,l ) = ( y( ij+1 , l ) - y( ij,l ) + + * x(ij +iip1, l ) - x( ij,l ) ) + 1 CONTINUE +c +c .... correction pour rot( iip1,j,l) .... +c +c .... rot(iip1,j,l)= rot(1,j,l) ... +CDIR$ IVDEP + DO 2 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim,l ) + 2 CONTINUE +c + 5 CONTINUE + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/serre.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/serre.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/serre.h (revision 1632) @@ -0,0 +1,11 @@ +! +! $Header$ +! +!c +!c +!c..include serre.h +!c + REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo, & + & grossismx, grossismy, dzoomx, dzoomy,taux,tauy + COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo , & + & grossismx, grossismy, dzoomx, dzoomy,taux,tauy Index: /LMDZ5/trunk/libf/dyn3dmem/sort.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/sort.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/sort.F (revision 1632) @@ -0,0 +1,37 @@ +! +! $Header$ +! +C +C + SUBROUTINE sort(n,d) +c +c P.Le Van +c +c... cette routine met le tableau d dans l'ordre croissant .... +cc ( pour avoir l'ordre decroissant,il suffit de remplacer l'instruc +c tion situee + bas IF(d(j).LE.p) THEN par +c IF(d(j).GE.p) THEN +c + + INTEGER n + REAL d(n) , p + INTEGER i,j,k + + DO i=1,n-1 + k=i + p=d(i) + DO j=i+1,n + IF(d(j).LE.p) THEN + k=j + p=d(j) + ENDIF + ENDDO + + IF(k.ne.i) THEN + d(k)=d(i) + d(i)=p + ENDIF + ENDDO + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/sortvarc0.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/sortvarc0.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/sortvarc0.F (revision 1632) @@ -0,0 +1,141 @@ +! +! $Id: sortvarc0.F 1299 2010-01-20 14:27:21Z fairhead $ +! + 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/dyn3dmem/spline.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/spline.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/spline.F (revision 1632) @@ -0,0 +1,79 @@ +! +! $Header$ +! + subroutine spline(x,y,n,yp1,ypn,y2) + +c + +c Routine to set up the interpolating function for a cubic spline + +c interpolation (see "Numerical Recipes" for details). + +c + implicit real (a-h,o-z) + implicit integer (i-n) + + parameter(nllm=4096) + + dimension x(n),y(n),y2(n),u(nllm) + +c +c write(6,*)(x(i),i=1,n) +c write(6,*)(y(i),i=1,n) + + if(yp1.gt.0.99E30) then +c the lower boundary condition is set + y2(1)=0. +c either to be "natural" + u(1)=0. + + else +c or else to have a specified first + y2(1)=-0.5 +c derivative + u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + + end if + + do 11 i=2,n-1 +c decomposition loop of the tridiagonal + sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) +c algorithm. Y2 and U are used + p=sig*y2(i-1)+2. +c for temporary storage of the decompo- + y2(i)=(sig-1.)/p +c sed factors + u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) + + . /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p + + 11 continue + + if(ypn.gt.0.99E30) then +c the upper boundary condition is set + qn=0. +c either to be "natural" + un=0. + + else +c or else to have a specified first + qn=0.5 +c derivative + un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) + + end if + + y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) + + do 12 k=n-1,1,-1 +c this is the backsubstitution loop of + y2(k)=y2(k)*y2(k+1)+u(k) +c the tridiagonal algorithm + 12 continue + +c + + return + + end + Index: /LMDZ5/trunk/libf/dyn3dmem/splint.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/splint.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/splint.F (revision 1632) @@ -0,0 +1,56 @@ +! +! $Header$ +! + + SUBROUTINE splint(xa,ya,y2a,n,x,y) + +c +c Routine to compute a cubic-spline interpolated value Y given the +c value of X, the arrays XA, YA and the 2nd derivative array Y2A +c computed by SUBROUTINE SPLINE. See "Numerical Recipes" for details +c + + IMPLICIT REAL (a-h,o-z) + IMPLICIT INTEGER (i-n) + DIMENSION xa(n),ya(n),y2a(n) + + kl0=1 + + khi=n +c means of bisection + 1 IF(khi-kl0.gt.1) THEN + + k=(khi+kl0)/2 + + IF(xa(k).gt.x) THEN + + khi=k + + ELSE + + kl0=k + + END IF + + GO TO 1 + + END IF +c KL0 and KHI now bracket the X + h=xa(khi)-xa(kl0) + + IF(h.eq.0.0) STOP + a=(xa(khi)-x)/h +c evaluation of cubic spline polynomial + b=(x-xa(kl0))/h + + y=a*ya(kl0)+b*ya(khi)+((a**3-a)*y2a(kl0)+(b**3-b)*y2a(khi))*(h**2) + + ./6. + +c + + RETURN + + END + + Index: /LMDZ5/trunk/libf/dyn3dmem/startvar.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/startvar.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/startvar.F (revision 1632) @@ -0,0 +1,1205 @@ +! +! $Id: startvar.F 1299 2010-01-20 14:27:21Z fairhead $ +! + MODULE startvar +#ifdef CPP_EARTH +! This module is designed to work for Earth (and with ioipsl) + ! + ! + ! There are three ways to access data from the database of atmospheric data which + ! can be used to initialize the model. This depends on the type of field which needs + ! to be extracted. + ! We will details the possible arguments to startget here : + ! + ! - A 2D variable on the dynamical grid : + ! CALL startget_phys2d(varname, iml, jml, lon_in, lat_in, champ, val_ex, jml2, lon_in2, lat_in2, interbar ) + ! + ! - 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, interbar ) + ! + ! + ! - 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, interbar ) + ! + ! + ! There is special constraint on the atmospheric data base except that the + ! the data needs to be in netCDF and the variables should have the the following + ! names in the file : + ! + ! '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 + ! + USE ioipsl + ! + ! + IMPLICIT NONE + ! + ! + PRIVATE + public startget_phys2d, startget_phys1d, startget_dyn + ! + INTEGER, SAVE :: fid_phys, fid_dyn + INTEGER, SAVE :: iml_phys, iml_rel, iml_dyn + INTEGER, SAVE :: jml_phys, jml_rel, jml_dyn + INTEGER, SAVE :: llm_dyn, ttm_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: lon_phys, lon_rug, + . lon_alb, lon_rel, lon_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: lat_phys, lat_rug, + . lat_alb, lat_rel, lat_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:) :: levdyn_ini + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: relief, zstd, zsig, + . zgam, zthe, zpic, zval + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: rugo, masque, phis + ! + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: tsol, qsol, psol_dyn + REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: var_ana3d + ! + CONTAINS + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in, + . champ, val_exp, jml2, lon_in2, lat_in2 , interbar, masque_lu ) + ! + ! There is a big mess with the size in logitude, 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 smaler fields when needed. This needs to be cleared once and for all in LMDZ. + ! A convention is required. + ! + ! + CHARACTER*(*), INTENT(in) :: varname + INTEGER, INTENT(in) :: iml, jml ,jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + REAL, INTENT(inout) :: champ(iml,jml) + REAL, INTENT(in) :: val_exp + REAL, INTENT(in), optional :: masque_lu(iml,jml) + LOGICAL interbar + ! + ! This routine only works if the variable does not exist or is constant + ! + IF ( MINVAL(champ(:,:)).EQ.MAXVAL(champ(:,:)) .AND. + .MINVAL(champ(:,:)).EQ.val_exp ) THEN + ! + SELECTCASE(varname) + ! + CASE ('relief') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(relief)) THEN + ! + if (present(masque_lu)) then + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2, interbar, masque_lu ) + else + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2, interbar) + endif + ! + ENDIF + ! + IF (SIZE(relief) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) 'STARTVAR module has been', + .' initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = relief(:,:) + ! + CASE ('rugosite') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(rugo)) THEN + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(rugo) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = rugo(:,:) + ! + CASE ('masque') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(masque)) THEN + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2,lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(masque) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = masque(:,:) + ! + CASE ('surfgeo') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(phis)) THEN + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2,lon_in2, lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(phis) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = phis(:,:) + ! + CASE ('psol') + ! + ! If we do not have the orography we need to get it + ! + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + ! + CALL start_init_dyn( iml, jml, lon_in, lat_in, + . jml2,lon_in2, lat_in2 , interbar ) + ! + ENDIF + ! + IF (SIZE(psol_dyn) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + champ(:,:) = psol_dyn(:,:) + ! + CASE DEFAULT + ! + WRITE(*,*) 'startget_phys2d' + WRITE(*,*) 'No rule is present to extract variable', + . varname(:LEN_TRIM(varname)),' from any data set' + STOP + ! + END SELECT + ! + ELSE + ! + ! There are a few fields we might need if we need to interpolate 3D filed. Thus if they come through here we + ! will catch them + ! + SELECTCASE(varname) + ! + CASE ('surfgeo') + ! + IF ( .NOT.ALLOCATED(phis)) THEN + ALLOCATE(phis(iml,jml)) + ENDIF + ! + IF (SIZE(phis) .NE. SIZE(champ)) THEN + ! + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ! + ENDIF + ! + phis(:,:) = champ(:,:) + ! + END SELECT + ! + ENDIF + ! + END SUBROUTINE startget_phys2d + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE start_init_orog ( iml,jml,lon_in, lat_in,jml2,lon_in2 , + , lat_in2 , interbar, masque_lu ) + ! + INTEGER, INTENT(in) :: iml, jml, jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + REAL, intent(in), optional :: masque_lu(iml,jml) + LOGICAL interbar + ! + ! LOCAL + ! + LOGICAL interbar2 + REAL :: lev(1), date, dt,chmin,chmax + INTEGER :: itau(1), fid + INTEGER :: llm_tmp, ttm_tmp + INTEGER :: i, j + INTEGER :: iret + CHARACTER*25 title + REAL, ALLOCATABLE :: relief_hi(:,:) + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) + REAL, ALLOCATABLE :: tmp_var(:,:) + INTEGER, ALLOCATABLE :: tmp_int(:,:) + ! + CHARACTER*120 :: orogfname + LOGICAL :: check=.TRUE. + ! + ! + orogfname = 'Relief.nc' + ! + IF ( check ) WRITE(*,*) 'Reading the high resolution orography' + ! + CALL flininfo(orogfname,iml_rel, jml_rel, llm_tmp, ttm_tmp, fid) + ! + ALLOCATE (lat_rel(iml_rel,jml_rel), stat=iret) + ALLOCATE (lon_rel(iml_rel,jml_rel), stat=iret) + ALLOCATE (relief_hi(iml_rel,jml_rel), stat=iret) + ! + CALL flinopen(orogfname, .FALSE., iml_rel, jml_rel, + .llm_tmp, lon_rel, lat_rel, lev, ttm_tmp, + . itau, date, dt, fid) + ! + CALL flinget(fid, 'RELIEF', iml_rel, jml_rel, llm_tmp, + . ttm_tmp, 1, 1, relief_hi) + ! + CALL flinclo(fid) + ! + ! In case we have a file which is in degrees we do the transformation + ! + ALLOCATE(lon_rad(iml_rel)) + ALLOCATE(lon_ini(iml_rel)) + + IF ( MAXVAL(lon_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_rel(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_rel(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_rel)) + ALLOCATE(lat_ini(jml_rel)) + + IF ( MAXVAL(lat_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_rel(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_rel(1,:) + ENDIF + ! + ! + + title='RELIEF' + + interbar2 = .FALSE. + CALL conf_dat2d(title,iml_rel, jml_rel, lon_ini, lat_ini, + . lon_rad, lat_rad, relief_hi , interbar2 ) + + IF ( check ) WRITE(*,*) 'Computes all the parameters needed', + .' for the gravity wave drag code' + ! + ! Allocate the data we need to put in the interpolated fields + ! + ! RELIEF: orographie moyenne + ALLOCATE(relief(iml,jml)) + ! zphi : orographie moyenne + ALLOCATE(phis(iml,jml)) + ! zstd: deviation standard de l'orographie sous-maille + ALLOCATE(zstd(iml,jml)) + ! zsig: pente de l'orographie sous-maille + ALLOCATE(zsig(iml,jml)) + ! zgam: anisotropy de l'orographie sous maille + ALLOCATE(zgam(iml,jml)) + ! zthe: orientation de l'axe oriente dans la direction + ! de plus grande pente de l'orographie sous maille + ALLOCATE(zthe(iml,jml)) + ! zpic: hauteur pics de la SSO + ALLOCATE(zpic(iml,jml)) + ! zval: hauteur vallees de la SSO + ALLOCATE(zval(iml,jml)) + ! masque : Masque terre ocean + ALLOCATE(tmp_int(iml,jml)) + ALLOCATE(masque(iml,jml)) + + masque = -99999. + if (present(masque_lu)) then + masque = masque_lu + endif + ! + 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 + ! +! masque(:,:) = REAL(tmp_int(:,:)) + ! + ! Compute surface roughness + ! + IF ( check ) WRITE(*,*) + .'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) + ! + DO j = 1, jml + DO i = 1, iml-1 + rugo(i,j) = tmp_var(i,j) + ENDDO + rugo(iml,j) = tmp_var(1,j) + ENDDO +c +cc *** rugo n'est pas utilise pour l'instant ****** + ! + ! Build land-sea mask + ! + ! + RETURN + ! + END SUBROUTINE start_init_orog + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, + .lat_in, nbindex, champ, val_exp ,jml2, lon_in2, lat_in2,interbar) + ! + CHARACTER*(*), INTENT(in) :: varname + INTEGER, INTENT(in) :: iml, jml, nbindex, jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + REAL, INTENT(inout) :: champ(nbindex) + REAL, INTENT(in) :: val_exp + LOGICAL interbar + ! + ! + ! This routine only works if the variable does not exist or is constant + ! + IF ( MINVAL(champ(:)).EQ.MAXVAL(champ(:)) .AND. + .MINVAL(champ(:)).EQ.val_exp ) THEN + SELECTCASE(varname) + CASE ('tsol') + IF ( .NOT.ALLOCATED(tsol)) THEN + CALL start_init_phys( iml, jml, lon_in, lat_in, + . jml2, lon_in2, lat_in2, interbar ) + ENDIF + IF ( SIZE(tsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, tsol, champ) + CASE ('qsol') + IF ( .NOT.ALLOCATED(qsol)) THEN + CALL start_init_phys( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(qsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, qsol, champ) + CASE ('psol') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF (SIZE(psol_dyn) .NE. SIZE(lon_in)*SIZE(lat_in)) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, psol_dyn, champ) + CASE ('zmea') + IF ( .NOT.ALLOCATED(relief)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(relief) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex, relief, champ) + CASE ('zstd') + IF ( .NOT.ALLOCATED(zstd)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zstd) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zstd, champ) + CASE ('zsig') + IF ( .NOT.ALLOCATED(zsig)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zsig) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zsig, champ) + CASE ('zgam') + IF ( .NOT.ALLOCATED(zgam)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zgam) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zgam, champ) + CASE ('zthe') + IF ( .NOT.ALLOCATED(zthe)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zthe) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zthe, champ) + CASE ('zpic') + IF ( .NOT.ALLOCATED(zpic)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zpic) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zpic, champ) + CASE ('zval') + IF ( .NOT.ALLOCATED(zval)) THEN + CALL start_init_orog( iml, jml, lon_in, lat_in, + . jml2, lon_in2,lat_in2 , interbar ) + ENDIF + IF ( SIZE(zval) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN + WRITE(*,*) + . 'STARTVAR module has been initialized to the wrong size' + STOP + ENDIF + CALL gr_dyn_fi(1, iml, jml, nbindex,zval, champ) + CASE ('rads') + champ(:) = 0.0 + CASE ('snow') + champ(:) = 0.0 +cIM "slab" ocean + CASE ('tslab') + champ(:) = 0.0 + CASE ('seaice') + champ(:) = 0.0 + CASE ('rugmer') + champ(:) = 0.001 + CASE ('agsno') + champ(:) = 50.0 + CASE DEFAULT + WRITE(*,*) 'startget_phys1d' + WRITE(*,*) 'No rule is present to extract variable ', + . varname(:LEN_TRIM(varname)),' from any data set' + STOP + END SELECT + ELSE + ! + ! If we see tsol we catch it as we may need it for a 3D interpolation + ! + SELECTCASE(varname) + CASE ('tsol') + IF ( .NOT.ALLOCATED(tsol)) THEN + ALLOCATE(tsol(SIZE(lon_in),SIZE(lat_in) )) + ENDIF + CALL gr_fi_dyn(1, iml, jml, nbindex, champ, tsol) + END SELECT + ENDIF + END SUBROUTINE startget_phys1d + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE start_init_phys( iml, jml, lon_in, lat_in, jml2, + . lon_in2, lat_in2 , interbar ) + + use inter_barxy_m, only: inter_barxy + ! + INTEGER, INTENT(in) :: iml, jml ,jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + LOGICAL interbar + ! + ! LOCAL + ! +!ac REAL :: lev(1), date, dt + REAL :: date, dt + REAL, DIMENSION(:), ALLOCATABLE :: levphys_ini +!ac + INTEGER :: itau(1) + INTEGER :: llm_tmp, ttm_tmp + INTEGER :: i, j + ! + CHARACTER*25 title + CHARACTER*120 :: physfname + LOGICAL :: check=.TRUE. + ! + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) + REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:) + ! + physfname = 'ECPHY.nc' + ! + IF ( check ) WRITE(*,*) '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)) +!ac + ALLOCATE (levphys_ini(llm_tmp)) + ! +! CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, +! . llm_tmp, lon_phys, lat_phys, lev, ttm_tmp, +! . itau, date, dt, fid_phys) + ! + 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) +!ac + ! + ! Allocate the space we will need to get the data out of this file + ! + ALLOCATE(var_ana(iml_phys, jml_phys)) + ! + ! In case we have a file which is in degrees we do the transformation + ! + ALLOCATE(lon_rad(iml_phys)) + ALLOCATE(lon_ini(iml_phys)) + + IF ( MAXVAL(lon_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_phys(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_phys(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_phys)) + ALLOCATE(lat_ini(jml_phys)) + + IF ( MAXVAL(lat_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_phys(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_phys(1,:) + ENDIF + + + ! + ! We get the two standard varibales + ! Surface temperature + ! + ALLOCATE(tsol(iml,jml)) + ALLOCATE(tmp_var(iml-1,jml)) + ! + ! + + CALL flinget(fid_phys, 'ST', iml_phys, jml_phys, + .llm_tmp, ttm_tmp, 1, 1, var_ana) + + title='ST' + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana , interbar ) + + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour ST $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy(lon_rad, lat_rad(:jml_phys -1), var_ana, + $ lon_in2(:iml-1), lat_in2(:jml-1), tmp_var) + ELSE + CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad, + . var_ana, iml-1, jml, lon_in, lat_in, tmp_var ) + ENDIF + + CALL gr_int_dyn(tmp_var, tsol, iml-1, jml) + ! + ! Soil moisture + ! + ALLOCATE(qsol(iml,jml)) + CALL flinget(fid_phys, 'CDSW', iml_phys, jml_phys, + . llm_tmp, ttm_tmp, 1, 1, var_ana) + + title='CDSW' + CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana, interbar ) + + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour CDSW $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy(lon_rad, lat_rad(:jml_phys -1), var_ana, + $ lon_in2(:iml-1), lat_in2(:jml-1), tmp_var) + ELSE + CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad, + . var_ana, iml-1, jml, lon_in, lat_in, tmp_var ) + ENDIF +c + CALL gr_int_dyn(tmp_var, qsol, iml-1, jml) + ! + CALL flinclo(fid_phys) + ! + END SUBROUTINE start_init_phys + ! + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! + SUBROUTINE startget_dyn(varname, lon_in, lat_in, + . pls, workvar, champ, val_exp, lon_in2, lat_in2 , + , interbar ) + + use assert_eq_m, only: assert_eq + ! + ! ARGUMENTS + ! + CHARACTER(len=*), INTENT(in) :: varname + REAL, INTENT(in) :: lon_in(:) ! dim(iml) + REAL, INTENT(in) :: lat_in(:) ! dim(jml) + REAL, INTENT(in) :: lon_in2(:) ! dim(iml) + REAL, INTENT(in) :: lat_in2(:) ! dim(jml2) + 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 + LOGICAL interbar + ! + ! LOCAL + ! + INTEGER :: il, ij, ii, iml, jml, lml, jml2 + REAL :: xppn, xpps + ! +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" +#include "comconst.h" + ! + ! This routine only works if the variable does not exist or is constant + ! +C ----------------------------- + + 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) + + IF ( MINVAL(champ(:,:,:)).EQ.MAXVAL(champ(:,:,:)) .AND. + . MINVAL(champ(:,:,:)).EQ.val_exp ) THEN + ! + SELECTCASE(varname) + CASE ('u') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , + . lon_in2,lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('U', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ,interbar ) + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = champ(ii,ij,il) * cu(ii,ij) + ENDDO + champ(iml,ij, il) = champ(1,ij, il) + ENDDO + ENDDO + CASE ('v') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2, + . lon_in2, lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('V', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = champ(ii,ij,il) * cv(ii,ij) + ENDDO + champ(iml,ij, il) = champ(1,ij, il) + ENDDO + ENDDO + CASE ('t') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , + . lon_in2, lat_in2 ,interbar ) + ENDIF + CALL start_inter_3d('TEMP', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) + + CASE ('tpot') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2 , + . lon_in2, lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('TEMP', iml, jml, lml, lon_in, + . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) + IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) + . THEN + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = champ(ii,ij,il) * cpp + . / workvar(ii,ij,il) + ENDDO + champ(iml,ij,il) = champ(1,ij,il) + ENDDO + ENDDO + 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 + ENDDO + ELSE + WRITE(*,*)'Could not compute potential temperature as the' + WRITE(*,*)'Exner function is missing or constant.' + STOP + ENDIF + CASE ('q') + IF ( .NOT.ALLOCATED(psol_dyn)) THEN + CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , + . lon_in2, lat_in2 , interbar ) + ENDIF + CALL start_inter_3d('R', iml, jml, lml, lon_in, lat_in, + . jml2, lon_in2, lat_in2, pls, champ, interbar ) + IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) + . THEN + DO il=1,lml + DO ij=1,jml + DO ii=1,iml-1 + champ(ii,ij,il) = 0.01 * champ(ii,ij,il) * + . workvar(ii,ij,il) + ENDDO + champ(iml,ij,il) = champ(1,ij,il) + ENDDO + ENDDO + WHERE ( champ .LT. 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 + ENDDO + ELSE + WRITE(*,*)'Could not compute specific humidity as the' + WRITE(*,*)'saturated humidity is missing or constant.' + STOP + ENDIF + CASE DEFAULT + WRITE(*,*) 'startget_dyn' + WRITE(*,*) 'No rule is present to extract variable ', + . varname(:LEN_TRIM(varname)),' from any data set' + STOP + END SELECT + ENDIF + END SUBROUTINE startget_dyn + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + SUBROUTINE start_init_dyn( iml, jml, lon_in, lat_in,jml2,lon_in2 , + , lat_in2 , interbar ) + ! + use inter_barxy_m, only: inter_barxy + + INTEGER, INTENT(in) :: iml, jml, jml2 + REAL, INTENT(in) :: lon_in(iml), lat_in(jml) + REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) + LOGICAL interbar + ! + ! LOCAL + ! + REAL :: lev(1), date, dt + INTEGER :: itau(1) + INTEGER :: i, j + integer :: iret + ! + CHARACTER*120 :: physfname + LOGICAL :: check=.TRUE. + ! + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) + REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:), z(:,:) + REAL, ALLOCATABLE :: xppn(:), xpps(:) + LOGICAL :: allo + ! + ! +#include "dimensions.h" +#include "paramet.h" +#include "comgeom2.h" + + CHARACTER*25 title + + ! + physfname = 'ECDYN.nc' + ! + IF ( check ) WRITE(*,*) 'Opening the surface analysis' + ! + CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn, + . ttm_dyn, fid_dyn) + IF ( check ) WRITE(*,*) 'Values read: ', iml_dyn, jml_dyn, + . llm_dyn, ttm_dyn + ! + ALLOCATE (lat_dyn(iml_dyn,jml_dyn), stat=iret) + ALLOCATE (lon_dyn(iml_dyn,jml_dyn), stat=iret) + ALLOCATE (levdyn_ini(llm_dyn), stat=iret) + ! + CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn, + . lon_dyn, lat_dyn, levdyn_ini, ttm_dyn, + . itau, date, dt, fid_dyn) + ! + + allo = allocated (var_ana) + if (allo) then + DEALLOCATE(var_ana, stat=iret) + endif + ALLOCATE(var_ana(iml_dyn, jml_dyn), stat=iret) + + allo = allocated (lon_rad) + if (allo) then + DEALLOCATE(lon_rad, stat=iret) + endif + + ALLOCATE(lon_rad(iml_dyn), stat=iret) + ALLOCATE(lon_ini(iml_dyn)) + + IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_dyn(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_dyn)) + ALLOCATE(lat_ini(jml_dyn)) + + IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_dyn(1,:) + ENDIF + ! + + + ALLOCATE(z(iml, jml)) + ALLOCATE(tmp_var(iml-1,jml)) + ! + CALL flinget(fid_dyn, 'Z', iml_dyn, jml_dyn, 0, ttm_dyn, + . 1, 1, var_ana) +c + title='Z' + CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana, interbar ) +c + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour Z $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy(lon_rad, lat_rad(:jml_dyn -1), var_ana, + $ lon_in2(:iml-1), lat_in2(:jml-1), tmp_var) + ELSE + CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana, + . iml-1, jml, lon_in, lat_in, tmp_var) + ENDIF + + CALL gr_int_dyn(tmp_var, z, iml-1, jml) + ! + ALLOCATE(psol_dyn(iml, jml)) + ! + CALL flinget(fid_dyn, 'SP', iml_dyn, jml_dyn, 0, ttm_dyn, + . 1, 1, var_ana) + + title='SP' + CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini, + . lon_rad, lat_rad, var_ana, interbar ) + + IF ( interbar ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour SP $$$ ' + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + CALL inter_barxy(lon_rad, lat_rad(:jml_dyn -1), var_ana, + $ lon_in2(:iml-1), lat_in2(:jml-1), tmp_var) + ELSE + CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana, + . iml-1, jml, lon_in, lat_in, tmp_var ) + ENDIF + + CALL gr_int_dyn(tmp_var, psol_dyn, iml-1, jml) + ! + IF ( .NOT.ALLOCATED(tsol)) THEN + ! These variables may have been allocated by the need to + ! create a start field for them or by the varibale + ! coming out of the restart file. In case we dor have it we will initialize it. + ! + CALL start_init_phys( iml, jml, lon_in, lat_in,jml2,lon_in2, + . lat_in2 , interbar ) + ELSE + IF ( SIZE(tsol) .NE. SIZE(psol_dyn) ) THEN + WRITE(*,*) 'start_init_dyn :' + WRITE(*,*) 'The temperature field we have does not ', + . 'have the right size' + STOP + ENDIF + ENDIF + IF ( .NOT.ALLOCATED(phis)) THEN + ! + ! These variables may have been allocated by the need to create a start field for them or by the varibale + ! coming out of the restart file. In case we dor have it we will initialize it. + ! + CALL start_init_orog( iml, jml, lon_in, lat_in, jml2, lon_in2 , + . lat_in2 , interbar ) + ! + ELSE + ! + IF (SIZE(phis) .NE. SIZE(psol_dyn)) THEN + ! + WRITE(*,*) 'start_init_dyn :' + WRITE(*,*) 'The orography field we have does not ', + . ' have the right size' + STOP + ENDIF + ! + ENDIF + ! + ! 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)) + ENDDO + psol_dyn(iml,j) = psol_dyn(1,j) + ENDDO + ! + ! + ALLOCATE(xppn(iml-1)) + ALLOCATE(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) + ENDDO + ! + DO i = 1, iml + psol_dyn(i,1 ) = SUM(xppn)/apoln + psol_dyn(i,jml) = SUM(xpps)/apols + ENDDO + ! + 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, interbar ) + ! + ! This subroutine gets a variables from a 3D file and does the interpolations needed + ! + ! + use inter_barxy_m, only: inter_barxy + + ! ARGUMENTS + ! + CHARACTER*(*) :: varname + INTEGER :: iml, jml, lml, jml2 + REAL :: lon_in(iml), lat_in(jml), pls_in(iml, jml, lml) + REAL :: lon_in2(iml) , lat_in2(jml2) + REAL :: var3d(iml, jml, lml) + LOGICAL interbar + real chmin,chmax + ! + ! LOCAL + ! + CHARACTER*25 title + INTEGER :: ii, ij, il, jsort,i,j,l + REAL :: bx, by + REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) + REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) , lev_dyn(:) + REAL, ALLOCATABLE :: var_tmp2d(:,:), var_tmp3d(:,:,:) + REAL, ALLOCATABLE :: ax(:), ay(:), yder(:) +! REAL, ALLOCATABLE :: varrr(:,:,:) + INTEGER, ALLOCATABLE :: lind(:) + ! + LOGICAL :: check = .TRUE. + ! + IF ( .NOT. ALLOCATED(var_ana3d)) THEN + ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn)) + ENDIF +! ALLOCATE(varrr(iml_dyn, jml_dyn, llm_dyn)) + ! + ! + IF ( check) WRITE(*,*) 'Going into flinget to extract the 3D ', + . ' field.', fid_dyn + IF ( check) WRITE(*,*) fid_dyn, varname, iml_dyn, jml_dyn, + . llm_dyn,ttm_dyn + ! + CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, + . ttm_dyn, 1, 1, var_ana3d) + ! + IF ( check) WRITE(*,*) 'Allocating space for the interpolation', + . iml, jml, llm_dyn + ! + ALLOCATE(lon_rad(iml_dyn)) + ALLOCATE(lon_ini(iml_dyn)) + + IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lon_ini(:) = lon_dyn(:,1) + ENDIF + + ALLOCATE(lat_rad(jml_dyn)) + ALLOCATE(lat_ini(jml_dyn)) + + ALLOCATE(lev_dyn(llm_dyn)) + + IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN + lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0 + ELSE + lat_ini(:) = lat_dyn(1,:) + ENDIF + ! + + CALL conf_dat3d ( varname,iml_dyn, jml_dyn, llm_dyn, lon_ini, + . lat_ini, levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d , + , interbar ) + + ALLOCATE(var_tmp2d(iml-1, jml)) + ALLOCATE(var_tmp3d(iml, jml, llm_dyn)) + ALLOCATE(ax(llm_dyn)) + ALLOCATE(ay(llm_dyn)) + ALLOCATE(yder(llm_dyn)) + ALLOCATE(lind(llm_dyn)) + ! + + DO il=1,llm_dyn + ! + IF( interbar ) THEN + IF( il.EQ.1 ) THEN + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', + , ' pour ', varname + WRITE(6,*) '-------------------------------------------------', + ,'--------------' + ENDIF + CALL inter_barxy(lon_rad, lat_rad(:jml_dyn -1), + $ var_ana3d(:,:,il), lon_in2(:iml-1), lat_in2, var_tmp2d) + ELSE + CALL grille_m(iml_dyn, jml_dyn, lon_rad, lat_rad, + . var_ana3d(:,:,il), iml-1, jml, lon_in, lat_in, var_tmp2d ) + ENDIF + ! + CALL gr_int_dyn(var_tmp2d, var_tmp3d(:,:,il), iml-1, jml) + ! + ENDDO + ! + DO il=1,llm_dyn + lind(il) = llm_dyn-il+1 + ENDDO + ! +c +c ... Pour l'interpolation verticale ,on interpole du haut de l'atmosphere +c vers le sol ... +c + DO ij=1,jml + DO ii=1,iml-1 + ! + ax(:) = lev_dyn(lind(:)) + ay(:) = var_tmp3d(ii, ij, lind(:)) + ! + + CALL SPLINE(ax, ay, llm_dyn, 1.e30, 1.e30, yder) + ! + DO il=1,lml + bx = pls_in(ii, ij, il) + CALL SPLINT(ax, ay, yder, llm_dyn, bx, by) + var3d(ii, ij, il) = by + ENDDO + ! + ENDDO + var3d(iml, ij, :) = var3d(1, ij, :) + ENDDO + + do il=1,lml + call minmax(iml*jml,var3d(1,1,il),chmin,chmax) + SELECTCASE(varname) + CASE('U') + WRITE(*,*) ' U min max l ',il,chmin,chmax + CASE('V') + WRITE(*,*) ' V min max l ',il,chmin,chmax + CASE('TEMP') + WRITE(*,*) ' TEMP min max l ',il,chmin,chmax + CASE('R') + WRITE(*,*) ' R min max l ',il,chmin,chmax + END SELECT + enddo + + DEALLOCATE(lon_rad) + DEALLOCATE(lon_ini) + DEALLOCATE(lat_rad) + DEALLOCATE(lat_ini) + DEALLOCATE(lev_dyn) + DEALLOCATE(var_tmp2d) + DEALLOCATE(var_tmp3d) + DEALLOCATE(ax) + DEALLOCATE(ay) + DEALLOCATE(yder) + DEALLOCATE(lind) + + ! + RETURN + ! + END SUBROUTINE start_inter_3d + ! +#endif +! of #ifdef CPP_EARTH + END MODULE startvar Index: /LMDZ5/trunk/libf/dyn3dmem/temps.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/temps.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/temps.h (revision 1632) @@ -0,0 +1,25 @@ +! +! $Id: temps.h 1279 2009-12-10 09:02:56Z fairhead $ +! +! 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) +! +! +! jD_ref = jour julien de la date de reference (lancement de l'experience) +! hD_ref = "heure" julienne de la date de reference +!----------------------------------------------------------------------- +! INCLUDE 'temps.h' + + COMMON/temps/itaufin, dt, day_ini, day_end, annee_ref, day_ref, & + & itau_dyn, itau_phy, jD_ref, jH_ref, calend + + INTEGER itaufin + INTEGER itau_dyn, itau_phy + INTEGER day_ini, day_end, annee_ref, day_ref + REAL dt, jD_ref, jH_ref + CHARACTER (len=10) :: calend + +!$OMP THREADPRIVATE(/temps/) +!----------------------------------------------------------------------- Index: /LMDZ5/trunk/libf/dyn3dmem/test_period.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/test_period.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/test_period.F (revision 1632) @@ -0,0 +1,115 @@ +! +! $Header$ +! + SUBROUTINE test_period ( ucov, vcov, teta, q, p, phis ) + USE infotrac, ONLY : nqtot +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 +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/dyn3dmem/times.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/times.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/times.F90 (revision 1632) @@ -0,0 +1,248 @@ +module times + integer,private,save :: Last_Count=0 + real, private,save :: Last_cpuCount=0 + logical, private,save :: AllTimer_IsActive=.false. + + integer, parameter :: nb_timer = 4 + integer, parameter :: timer_caldyn = 1 + integer, parameter :: timer_vanleer = 2 + integer, parameter :: timer_dissip = 3 + integer, parameter :: timer_physic = 4 + integer, parameter :: stopped = 1 + integer, parameter :: running = 2 + integer, parameter :: suspended = 3 + + integer :: max_size + real, allocatable, dimension(:,:,:) :: timer_table + real, allocatable, dimension(:,:,:) :: timer_table_sqr + integer, allocatable, dimension(:,:,:) :: timer_iteration + real, allocatable, dimension(:,:,:) :: timer_average + real, allocatable, dimension(:,:,:) :: timer_delta + real, allocatable,dimension(:) :: timer_running, last_time + integer, allocatable,dimension(:) :: timer_state + + contains + + subroutine init_timer + use parallel + implicit none +#include "dimensions.h" +#include "paramet.h" + + max_size=jjm+1 + allocate(timer_table(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_table_sqr(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_iteration(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_average(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_delta(max_size,nb_timer,0:mpi_size-1)) + allocate(timer_running(nb_timer)) + allocate(timer_state(nb_timer)) + allocate(last_time(nb_timer)) + + timer_table(:,:,:)=0 + timer_table_sqr(:,:,:)=0 + timer_iteration(:,:,:)=0 + timer_average(:,:,:)=0 + timer_delta(:,:,:)=0 + timer_state(:)=stopped + end subroutine init_timer + + subroutine start_timer(no_timer) + implicit none + integer :: no_timer + + if (AllTimer_IsActive) then + + if (timer_state(no_timer)/=stopped) then + stop 'start_timer :: timer is already running or suspended' + else + timer_state(no_timer)=running + endif + + timer_running(no_timer)=0 + call cpu_time(last_time(no_timer)) + + endif + + end subroutine start_timer + + subroutine suspend_timer(no_timer) + implicit none + integer :: no_timer + + if (AllTimer_IsActive) then + if (timer_state(no_timer)/=running) then + stop 'suspend_timer :: timer is not running' + else + timer_state(no_timer)=suspended + endif + + timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer) + call cpu_time(last_time(no_timer)) + timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer) + endif + end subroutine suspend_timer + + subroutine resume_timer(no_timer) + implicit none + integer :: no_timer + + if (AllTimer_IsActive) then + if (timer_state(no_timer)/=suspended) then + stop 'resume_timer :: timer is not suspended' + else + timer_state(no_timer)=running + endif + + call cpu_time(last_time(no_timer)) + endif + + end subroutine resume_timer + + subroutine stop_timer(no_timer) + use parallel + implicit none + integer :: no_timer + integer :: N + real :: V,V2 + + if (AllTimer_IsActive) then + + if (timer_state(no_timer)/=running) then + stop 'stop_timer :: timer is not running' + else + timer_state(no_timer)=stopped + endif + + timer_running(no_timer)=timer_running(no_timer)-last_time(no_timer) + call cpu_time(last_time(no_timer)) + timer_running(no_timer)=timer_running(no_timer)+last_time(no_timer) + + timer_table(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)+timer_running(no_timer) + timer_table_sqr(jj_nb,no_timer,mpi_rank)=timer_table_sqr(jj_nb,no_timer,mpi_rank)+timer_running(no_timer)**2 + timer_iteration(jj_nb,no_timer,mpi_rank)=timer_iteration(jj_nb,no_timer,mpi_rank)+1 + timer_average(jj_nb,no_timer,mpi_rank)=timer_table(jj_nb,no_timer,mpi_rank)/timer_iteration(jj_nb,no_timer,mpi_rank) + if (timer_iteration(jj_nb,no_timer,mpi_rank)>=2) then + N=timer_iteration(jj_nb,no_timer,mpi_rank) + V2=timer_table_sqr(jj_nb,no_timer,mpi_rank) + V=timer_table(jj_nb,no_timer,mpi_rank) + timer_delta(jj_nb,no_timer,mpi_rank)=sqrt(ABS(V2-V*V/N)/(N-1)) + else + timer_delta(jj_nb,no_timer,mpi_rank)=0 + endif + endif + + end subroutine stop_timer + + subroutine allgather_timer + use parallel + implicit none +#ifdef CPP_MPI + include 'mpif.h' +#endif + integer :: ierr + integer :: data_size + real, allocatable,dimension(:,:) :: tmp_table + + IF (using_mpi) THEN + + if (AllTimer_IsActive) then + + + allocate(tmp_table(max_size,nb_timer)) + + data_size=max_size*nb_timer + + tmp_table(:,:)=timer_table(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + tmp_table(:,:)=timer_table_sqr(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_table_sqr(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + deallocate(tmp_table) + + endif + + ENDIF ! using_mpi + + end subroutine allgather_timer + + subroutine allgather_timer_average + use parallel + implicit none +#ifdef CPP_MPI + include 'mpif.h' +#endif + integer :: ierr + integer :: data_size + real, allocatable,dimension(:,:),target :: tmp_table + integer, allocatable,dimension(:,:),target :: tmp_iter + integer :: istats + + IF (using_mpi) THEN + + if (AllTimer_IsActive) then + + allocate(tmp_table(max_size,nb_timer)) + allocate(tmp_iter(max_size,nb_timer)) + + data_size=max_size*nb_timer + + tmp_table(:,:)=timer_average(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_average(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + tmp_table(:,:)=timer_delta(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_table(1,1),data_size,MPI_REAL_LMDZ,timer_delta(1,1,0),data_size,MPI_REAL_LMDZ,COMM_LMDZ,ierr) +#endif + tmp_iter(:,:)=timer_iteration(:,:,mpi_rank) +#ifdef CPP_MPI + call mpi_allgather(tmp_iter(1,1),data_size,MPI_INTEGER,timer_iteration(1,1,0),data_size,MPI_INTEGER,COMM_LMDZ,ierr) +#endif + deallocate(tmp_table) + + endif + + ENDIF ! using_mp� + end subroutine allgather_timer_average + + subroutine InitTime + implicit none + integer :: count,count_rate,count_max + + AllTimer_IsActive=.TRUE. + if (AllTimer_IsActive) then + call system_clock(count,count_rate,count_max) + call cpu_time(Last_cpuCount) + Last_Count=count + endif + end subroutine InitTime + + function DiffTime() + implicit none + double precision :: DiffTime + integer :: count,count_rate,count_max + + call system_clock(count,count_rate,count_max) + if (Count>=Last_Count) then + DiffTime=(1.*(Count-last_Count))/count_rate + else + DiffTime=(1.*(Count-last_Count+Count_max))/count_rate + endif + Last_Count=Count + end function DiffTime + + function DiffCpuTime() + implicit none + real :: DiffCpuTime + real :: Count + + call cpu_time(Count) + DiffCpuTime=Count-Last_cpuCount + Last_cpuCount=Count + end function DiffCpuTime + +end module times Index: /LMDZ5/trunk/libf/dyn3dmem/top_bound_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/top_bound_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/top_bound_loc.F (revision 1632) @@ -0,0 +1,165 @@ + SUBROUTINE top_bound_loc( vcov,ucov,teta,masse, du,dv,dh ) + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + + +c .. DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO, +C F. LOTT DEC. 2006 +c ( 10/12/06 ) + +c======================================================================= +c +c Auteur: F. LOTT +c ------- +c +c Objet: +c ------ +c +c Dissipation linéaire (ex top_bound de la physique) +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "comdissipn.h" + +c Arguments: +c ---------- + + REAL ucov(iip1,jjb_u:jje_u,llm),vcov(iip1,jjb_v:jje_v,llm) + REAL teta(iip1,jjb_u:jje_u,llm) + REAL masse(iip1,jjb_u:jje_u,llm) + REAL dv(iip1,jjb_v:jje_v,llm),du(iip1,jjb_u:jje_u,llm) + REAL dh(iip1,jjb_u:jje_u,llm) + +c Local: +c ------ + REAL massebx(iip1,jjb_u:jje_u,llm),masseby(iip1,jjb_v:jje_v,llm) + REAL zm + REAL uzon(jjb_u:jje_u,llm),vzon(jjb_v:jje_v,llm) + REAL tzon(jjb_u:jje_u,llm) + + INTEGER NDAMP + PARAMETER (NDAMP=4) + integer i + REAL,SAVE :: rdamp(llm) +! & (/(0., i =1,llm-NDAMP),0.125E-5,.25E-5,.5E-5,1.E-5/) + LOGICAL,SAVE :: first=.true. + INTEGER j,l,jjb,jje + + + if (iflag_top_bound == 0) return + if (first) then +c$OMP BARRIER +c$OMP MASTER + if (iflag_top_bound == 1) then +! couche eponge dans les 4 dernieres couches du modele + rdamp(:)=0. + rdamp(llm)=tau_top_bound + rdamp(llm-1)=tau_top_bound/2. + rdamp(llm-2)=tau_top_bound/4. + rdamp(llm-3)=tau_top_bound/8. + else if (iflag_top_bound == 2) then +! couce eponge dans toutes les couches de pression plus faible que +! 100 fois la pression de la derniere couche + rdamp(:)=tau_top_bound + s *max(presnivs(llm)/presnivs(:)-0.01,0.) + endif + first=.false. + print*,'TOP_BOUND rdamp=',rdamp +c$OMP END MASTER +c$OMP BARRIER + endif + + + CALL massbar_loc(masse,massebx,masseby) +C CALCUL DES CHAMPS EN MOYENNE ZONALE: + + jjb=jj_begin + jje=jj_end + IF (pole_sud) jje=jj_end-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + zm=0. + vzon(j,l)=0 + do i=1,iim +! Rm: on peut travailler directement avec la moyenne zonale de vcov +! plutot qu'avec celle de v car le coefficient cv qui relie les deux +! ne varie qu'en latitude + vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l) + zm=zm+masseby(i,j,l) + enddo + vzon(j,l)=vzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iip1 + dv(i,j,l)=dv(i,j,l)-rdamp(l)*(vcov(i,j,l)-vzon(j,l)) + enddo + enddo + enddo +c$OMP END DO NOWAIT + + jjb=jj_begin + jje=jj_end + IF (pole_nord) jjb=jj_begin+1 + IF (pole_sud) jje=jj_end-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + uzon(j,l)=0. + zm=0. + do i=1,iim + uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j) + zm=zm+massebx(i,j,l) + enddo + uzon(j,l)=uzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + zm=0. + tzon(j,l)=0. + do i=1,iim + tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l) + zm=zm+masse(i,j,l) + enddo + tzon(j,l)=tzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +C AMORTISSEMENTS LINEAIRES: + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iip1 + du(i,j,l)=du(i,j,l) + s -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l)) + dh(i,j,l)=dh(i,j,l)-rdamp(l)*(teta(i,j,l)-tzon(j,l)) + enddo + enddo + enddo +c$OMP END DO NOWAIT + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/top_bound_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/top_bound_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/top_bound_p.F (revision 1632) @@ -0,0 +1,161 @@ + SUBROUTINE top_bound_p( vcov,ucov,teta,masse, du,dv,dh ) + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom2.h" + + +c .. DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO, +C F. LOTT DEC. 2006 +c ( 10/12/06 ) + +c======================================================================= +c +c Auteur: F. LOTT +c ------- +c +c Objet: +c ------ +c +c Dissipation linéaire (ex top_bound de la physique) +c +c======================================================================= +c----------------------------------------------------------------------- +c Declarations: +c ------------- + +#include "comdissipn.h" + +c Arguments: +c ---------- + + REAL ucov(iip1,jjp1,llm),vcov(iip1,jjm,llm),teta(iip1,jjp1,llm) + REAL masse(iip1,jjp1,llm) + REAL dv(iip1,jjm,llm),du(iip1,jjp1,llm),dh(iip1,jjp1,llm) + +c Local: +c ------ + REAL massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm),zm + REAL uzon(jjp1,llm),vzon(jjm,llm),tzon(jjp1,llm) + + INTEGER NDAMP + PARAMETER (NDAMP=4) + integer i + REAL,SAVE :: rdamp(llm) +! & (/(0., i =1,llm-NDAMP),0.125E-5,.25E-5,.5E-5,1.E-5/) + LOGICAL,SAVE :: first=.true. + INTEGER j,l,jjb,jje + + + if (iflag_top_bound == 0) return + if (first) then +c$OMP BARRIER +c$OMP MASTER + if (iflag_top_bound == 1) then +! couche eponge dans les 4 dernieres couches du modele + rdamp(:)=0. + rdamp(llm)=tau_top_bound + rdamp(llm-1)=tau_top_bound/2. + rdamp(llm-2)=tau_top_bound/4. + rdamp(llm-3)=tau_top_bound/8. + else if (iflag_top_bound == 2) then +! couce eponge dans toutes les couches de pression plus faible que +! 100 fois la pression de la derniere couche + rdamp(:)=tau_top_bound + s *max(presnivs(llm)/presnivs(:)-0.01,0.) + endif + first=.false. + print*,'TOP_BOUND rdamp=',rdamp +c$OMP END MASTER +c$OMP BARRIER + endif + + + CALL massbar_p(masse,massebx,masseby) +C CALCUL DES CHAMPS EN MOYENNE ZONALE: + + jjb=jj_begin + jje=jj_end + IF (pole_sud) jje=jj_end-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + zm=0. + vzon(j,l)=0 + do i=1,iim +! Rm: on peut travailler directement avec la moyenne zonale de vcov +! plutot qu'avec celle de v car le coefficient cv qui relie les deux +! ne varie qu'en latitude + vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l) + zm=zm+masseby(i,j,l) + enddo + vzon(j,l)=vzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iip1 + dv(i,j,l)=dv(i,j,l)-rdamp(l)*(vcov(i,j,l)-vzon(j,l)) + enddo + enddo + enddo +c$OMP END DO NOWAIT + + jjb=jj_begin + jje=jj_end + IF (pole_nord) jjb=jj_begin+1 + IF (pole_sud) jje=jj_end-1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + uzon(j,l)=0. + zm=0. + do i=1,iim + uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j) + zm=zm+massebx(i,j,l) + enddo + uzon(j,l)=uzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + zm=0. + tzon(j,l)=0. + do i=1,iim + tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l) + zm=zm+masse(i,j,l) + enddo + tzon(j,l)=tzon(j,l)/zm + enddo + enddo +c$OMP END DO NOWAIT + +C AMORTISSEMENTS LINEAIRES: + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do l=1,llm + do j=jjb,jje + do i=1,iip1 + du(i,j,l)=du(i,j,l) + s -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l)) + dh(i,j,l)=dh(i,j,l)-rdamp(l)*(teta(i,j,l)-tzon(j,l)) + enddo + enddo + enddo +c$OMP END DO NOWAIT + + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/tourabs.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/tourabs.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/tourabs.F (revision 1632) @@ -0,0 +1,98 @@ + SUBROUTINE tourabs ( ntetaSTD,vcov, ucov, vorabs ) + IMPLICIT NONE + +c======================================================================= +c +c Modif: I. Musat (28/10/04) +c ------- +c adaptation du code tourpot.F pour le calcul de la vorticite absolue +c cf. P. Le Van +c +c Objet: +c ------ +c +c ******************************************************************* +c ............. calcul de la vorticite absolue ................. +c ******************************************************************* +c +c ntetaSTD, vcov,ucov sont des argum. d'entree pour le s-pg . +c vorabs est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" +#include "comconst.h" +c + INTEGER ntetaSTD + REAL vcov( ip1jm,ntetaSTD ), ucov( ip1jmp1,ntetaSTD ) + REAL vorabs( ip1jm,ntetaSTD ) +c +c variables locales + INTEGER l, ij, i, j + REAL rot( ip1jm,ntetaSTD ) + + + +c ... vorabs = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ + + DO 5 l = 1,ntetaSTD + + DO 2 i = 1, iip1 + DO 2 j = 1, jjm +c + ij=i+(j-1)*iip1 + IF(ij.LE.ip1jm - 1) THEN +c + IF(cv(ij).EQ.0..OR.cv(ij+1).EQ.0..OR. + $ cu(ij).EQ.0..OR.cu(ij+iip1).EQ.0.) THEN + rot( ij,l ) = 0. + continue + ELSE + rot( ij,l ) = (vcov(ij+1,l)/cv(ij+1)-vcov(ij,l)/cv(ij))/ + $ (2.*pi*RAD*cos(rlatv(j)))*REAL(iim) + $ +(ucov(ij+iip1,l)/cu(ij+iip1)-ucov(ij,l)/cu(ij))/ + $ (pi*RAD)*(REAL(jjm)-1.) +c + ENDIF + ENDIF !(ij.LE.ip1jm - 1) THEN + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + DO 3 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE + + + CALL filtreg( rot, jjm, ntetaSTD, 2, 1, .FALSE., 1 ) + + + DO 10 l = 1, ntetaSTD + + DO 6 ij = 1, ip1jm - 1 + vorabs( ij,l ) = ( rot(ij,l) + fext(ij)*unsairez(ij) ) + 6 CONTINUE + +c ..... correction pour vorabs( iip1,j,l) ..... +c .... vorabs(iip1,j,l)= vorabs(1,j,l) .... +CDIR$ IVDEP + DO 8 ij = iip1, ip1jm, iip1 + vorabs( ij,l ) = vorabs( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/tourpot.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/tourpot.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/tourpot.F (revision 1632) @@ -0,0 +1,81 @@ +! +! $Header$ +! + SUBROUTINE tourpot ( vcov, ucov, massebxy, vorpot ) + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c ......... calcul du tourbillon potentiel ......... +c ******************************************************************* +c +c vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg . +c vorpot est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" + + REAL rot( ip1jm,llm ) + REAL vcov( ip1jm,llm ),ucov( ip1jmp1,llm ) + REAL massebxy( ip1jm,llm ),vorpot( ip1jm,llm ) + + INTEGER l, ij + + + + +c ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ + + DO 5 l = 1,llm + + DO 2 ij = 1, ip1jm - 1 + rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l) + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + DO 3 ij = iip1, ip1jm, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE + + + CALL filtreg( rot, jjm, llm, 2, 1, .FALSE., 1 ) + + + DO 10 l = 1, llm + + DO 6 ij = 1, ip1jm - 1 + vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l) + 6 CONTINUE + +c ..... correction pour vorpot( iip1,j,l) ..... +c .... vorpot(iip1,j,l)= vorpot(1,j,l) .... +CDIR$ IVDEP + DO 8 ij = iip1, ip1jm, iip1 + vorpot( ij,l ) = vorpot( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/tourpot_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/tourpot_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/tourpot_loc.F (revision 1632) @@ -0,0 +1,95 @@ + SUBROUTINE tourpot_loc ( vcov, ucov, massebxy, vorpot ) + USE parallel + USE mod_filtreg_p + IMPLICIT NONE + +c======================================================================= +c +c Auteur: P. Le Van +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c ......... calcul du tourbillon potentiel ......... +c ******************************************************************* +c +c vcov,ucov,fext et pbarxyfl sont des argum. d'entree pour le s-pg . +c vorpot est un argum.de sortie pour le s-pg . +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comgeom.h" +#include "logic.h" + + REAL rot( ijb_v:ije_v,llm ) + REAL vcov( ijb_v:ije_v,llm ),ucov( ijb_u:ije_u,llm ) + REAL massebxy( ijb_v:ije_v,llm ),vorpot( ijb_v:ije_v,llm ) + + INTEGER l, ij ,ije,ijb,jje,jjb + + + ijb=ij_begin-iip1 + ije=ij_end + + if (pole_nord) ijb=ij_begin + + +c ... vorpot = ( Filtre( d(vcov)/dx - d(ucov)/dy ) + fext ) /psbarxy .. + + + +c ........ Calcul du rotationnel du vent V puis filtrage ........ +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 5 l = 1,llm + + if (pole_sud) ije=ij_end-iip1-1 + DO 2 ij = ijb, ije + rot( ij,l ) = vcov(ij+1,l)-vcov(ij,l)+ucov(ij+iip1,l)-ucov(ij,l) + 2 CONTINUE + +c .... correction pour rot( iip1,j,l ) ..... +c .... rot(iip1,j,l) = rot(1,j,l) ..... + +CDIR$ IVDEP + + if (pole_sud) ije=ij_end-iip1 + + DO 3 ij = ijb+iip1-1, ije, iip1 + rot( ij,l ) = rot( ij -iim, l ) + 3 CONTINUE + + 5 CONTINUE +c$OMP END DO NOWAIT + jjb=jj_begin-1 + jje=jj_end + + if (pole_nord) jjb=jjb+1 + if (pole_sud) jje=jje-1 + CALL filtreg_p( rot, jjb_v,jje_v,jjb,jje,jjm, llm, + & 2, 1, .FALSE., 1 ) + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 10 l = 1, llm + + if (pole_sud) ije=ij_end-iip1-1 + + DO 6 ij = ijb, ije + vorpot( ij,l ) = ( rot(ij,l) + fext(ij) ) / massebxy(ij,l) + 6 CONTINUE + +c ..... correction pour vorpot( iip1,j,l) ..... +c .... vorpot(iip1,j,l)= vorpot(1,j,l) .... +CDIR$ IVDEP + if (pole_sud) ije=ij_end-iip1 + DO 8 ij = ijb+iip1-1, ije, iip1 + vorpot( ij,l ) = vorpot( ij -iim,l ) + 8 CONTINUE + + 10 CONTINUE +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/traceurpole.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/traceurpole.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/traceurpole.F (revision 1632) @@ -0,0 +1,70 @@ +! +! $Id: traceurpole.F 1299 2010-01-20 14:27:21Z fairhead $ +! + 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/dyn3dmem/tracstoke.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/tracstoke.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/tracstoke.h (revision 1632) @@ -0,0 +1,5 @@ +! +! $Header$ +! + common /tracstoke/istdyn,istphy,unittrac + integer istdyn,istphy,unittrac Index: /LMDZ5/trunk/libf/dyn3dmem/ugeostr.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/ugeostr.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/ugeostr.F (revision 1632) @@ -0,0 +1,69 @@ +! +! $Id: ugeostr.F 1299 2010-01-20 14:27:21Z fairhead $ +! + subroutine ugeostr(phi,ucov) + + +c Calcul du vent covariant geostrophique a partir du champs de +c geopotentiel en supposant que le vent au sol est nul. + + 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)/ + s (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') + +c +c----------------------------------------------------------------------- +c calcul des champ de vent: +c ------------------------- + + DO 301 l=1,llm + DO 302 i=1,iip1 + ucov(i,1,l)=0. + ucov(i,jjp1,l)=0. +302 CONTINUE + DO 304 j=2,jjm + DO 305 i=1,iim + ucov(i,j,l) = 0.5*(u(i,j,l)+u(i,j-1,l))*cu(i,j) +305 CONTINUE + ucov(iip1,j,l)=ucov(1,j,l) +304 CONTINUE +301 CONTINUE + + print*,301 + + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/vitvert.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/vitvert.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/vitvert.F (revision 1632) @@ -0,0 +1,52 @@ +! +! $Header$ +! + SUBROUTINE vitvert ( convm , w ) +c + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul de la vitesse verticale aux niveaux sigma .... +c ******************************************************************* +c convm est un argument d'entree pour le s-pg ...... +c w est un argument de sortie pour le s-pg ...... +c +c la vitesse verticale est orientee de haut en bas . +c au sol, au niveau sigma(1), w(i,j,1) = 0. +c au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi +c egale a 0. et n'est pas stockee dans le tableau w . +c +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL w(ip1jmp1,llm),convm(ip1jmp1,llm) + INTEGER l, ij + + + + DO 2 l = 1,llmm1 + + DO 1 ij = 1,ip1jmp1 + w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 ) + 1 CONTINUE + + 2 CONTINUE + + DO 5 ij = 1,ip1jmp1 + w(ij,1) = 0. +5 CONTINUE + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/vitvert_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/vitvert_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/vitvert_loc.F (revision 1632) @@ -0,0 +1,56 @@ + SUBROUTINE vitvert_loc ( convm , w ) +c + USE parallel + IMPLICIT NONE + +c======================================================================= +c +c Auteurs: P. Le Van , F. Hourdin . +c ------- +c +c Objet: +c ------ +c +c ******************************************************************* +c .... calcul de la vitesse verticale aux niveaux sigma .... +c ******************************************************************* +c convm est un argument d'entree pour le s-pg ...... +c w est un argument de sortie pour le s-pg ...... +c +c la vitesse verticale est orientee de haut en bas . +c au sol, au niveau sigma(1), w(i,j,1) = 0. +c au sommet, au niveau sigma(llm+1) , la vit.verticale est aussi +c egale a 0. et n'est pas stockee dans le tableau w . +c +c +c======================================================================= + +#include "dimensions.h" +#include "paramet.h" +#include "comvert.h" + + REAL w(ijb_u:ije_u,llm),convm(ijb_u:ije_u,llm) + INTEGER l, ij,ijb,ije + + + ijb=ij_begin + ije=ij_end+iip1 + + if (pole_sud) ije=ij_end +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO 2 l = 1,llmm1 + + DO 1 ij = ijb,ije + w( ij, l+1 ) = convm( ij, l+1 ) - bp(l+1) * convm( ij, 1 ) + 1 CONTINUE + + 2 CONTINUE +c$OMP END DO +c$OMP MASTER + DO 5 ij = ijb,ije + w(ij,1) = 0. +5 CONTINUE +c$OMP END MASTER +c$OMP BARRIER + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/vlsplt_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/vlsplt_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/vlsplt_loc.F (revision 1632) @@ -0,0 +1,910 @@ + SUBROUTINE vlx_loc(q,pente_max,masse,u_m,ijb_x,ije_x) + +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 -------------------------------------------------------------------- + USE Parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ijb_u:ije_u,llm),pente_max + REAL u_m( ijb_u:ije_u,llm ),pbarv( iip1,jjb_v:jje_v,llm) + REAL q(ijb_u:ije_u,llm) + REAL w(ijb_u:ije_u,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ijnb_u),niju + INTEGER n0,iadvplus(ijb_u:ije_u,llm),nl(llm) +c + REAL new_m,zu_m,zdum(ijb_u:ije_u,llm) + REAL sigu(ijb_u:ije_u),dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u) + REAL zz(ijb_u:ije_u) + REAL adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm) + REAL u_mq(ijb_u:ije_u,llm) + + Logical extremum + + REAL SSUM + EXTERNAL SSUM + + REAL z1,z2,z3 + + INTEGER ijb,ije,ijb_x,ije_x + +c calcul de la pente a droite et a gauche de la maille + + ijb=ijb_x + ije=ije_x + + if (pole_nord.and.ijb==1) ijb=ijb+iip1 + if (pole_sud.and.ije==ip1jmp1) ije=ije-iip1 + + IF (pente_max.gt.-1.e-5) THEN +c IF (pente_max.gt.10) THEN + +c calcul des pentes avec limitation, Van Leer scheme I: +c ----------------------------------------------------- + +c calcul de la pente aux points u +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) +c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' +c sigu(ij)=u_m(ij,l)/masse(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) +c sigu(ij)=sigu(ij-iim) + ENDDO + + DO ij=ijb,ije + adxqu(ij)=abs(dxqu(ij)) + ENDDO + +c calcul de la pente maximum dans la maille en valeur absolue + + DO ij=ijb+1,ije + dxqmax(ij,l)=pente_max* + , min(adxqu(ij-1),adxqu(ij)) +c limitation subtile +c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) + + + ENDDO + + DO ij=ijb+iip1-1,ije,iip1 + dxqmax(ij-iim,l)=dxqmax(ij,l) + ENDDO + + DO ij=ijb+1,ije +#ifdef CRAY + dxq(ij,l)= + , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) +#else + IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN + dxq(ij,l)=dxqu(ij-1)+dxqu(ij) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF +#endif + dxq(ij,l)=0.5*dxq(ij,l) + dxq(ij,l)= + , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) + ENDDO + + ENDDO ! l=1,llm +c$OMP END DO NOWAIT +c print*,'Ok calcul des pentes' + + ELSE ! (pente_max.lt.-1.e-5) + +c Pentes produits: +c ---------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) + ENDDO + + DO ij=ijb+1,ije + zz(ij)=dxqu(ij-1)*dxqu(ij) + zz(ij)=zz(ij)+zz(ij) + IF(zz(ij).gt.0) THEN + dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + ENDIF ! (pente_max.lt.-1.e-5) + +c bouclage de la pente en iip1: +c ----------------------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + dxq(ij-iim,l)=dxq(ij,l) + ENDDO + DO ij=ijb,ije + iadvplus(ij,l)=0 + ENDDO + + ENDDO +c$OMP END DO NOWAIT +c print*,'Bouclage en iip1' + +c calcul des flux a gauche et a droite + +#ifdef CRAY +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), + , 1.+u_m(ij,l)/masse(ij+1,l), + , u_m(ij,l)) + zdum(ij,l)=0.5*zdum(ij,l) + u_mq(ij,l)=cvmgp( + , q(ij,l)+zdum(ij,l)*dxq(ij,l), + , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), + , u_m(ij,l)) + u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +#else +c on cumule le flux correspondant a toutes les mailles dont la masse +c au travers de la paroi pENDant le pas de temps. +c print*,'Cumule ....' +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 +c print*,'masse(',ij,')=',masse(ij,l) + IF (u_m(ij,l).gt.0.) THEN + zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) + u_mq(ij,l)=u_m(ij,l)*(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l)) + ELSE + zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) + u_mq(ij,l)=u_m(ij,l)*(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l)) + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT +#endif +c stop + +c go to 9999 +c detection des points ou on advecte plus que la masse de la +c maille +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + IF(zdum(ij,l).lt.0) THEN + iadvplus(ij,l)=1 + u_mq(ij,l)=0. + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT +c print*,'Ok test 1' +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + iadvplus(ij,l)=iadvplus(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c print*,'Ok test 2' + + +c traitement special pour le cas ou on advecte en longitude plus que le +c contenu de la maille. +c cette partie est mal vectorisee. + +c calcul du nombre de maille sur lequel on advecte plus que la maille. + + n0=0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + nl(l)=0 + DO ij=ijb,ije + nl(l)=nl(l)+iadvplus(ij,l) + ENDDO + n0=n0+nl(l) + ENDDO +c$OMP END DO NOWAIT +cym IF(n0.gt.1) THEN +cym IF(n0.gt.0) THEN + +c PRINT*,'Nombre de points pour lesquels on advect plus que le' +c & ,'contenu de la maille : ',n0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + IF(nl(l).gt.0) THEN + iju=0 +c indicage des mailles concernees par le traitement special + DO ij=ijb,ije + IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN + iju=iju+1 + indu(iju)=ij + ENDIF + ENDDO + niju=iju +c PRINT*,'niju,nl',niju,nl(l) + +c traitement des mailles + DO iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + IF(zu_m.gt.0.) THEN + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m* + & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) + ELSE + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- + & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) + ENDIF + ENDDO + ENDIF + ENDDO +c$OMP END DO NOWAIT +cym ENDIF ! n0.gt.0 +9999 continue + + +c bouclage en latitude +c print*,'Avant bouclage en latitude' +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c calcul des tENDances +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+1,ije + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + ENDDO +c ModIF Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + DO ij=ijb+iip1-1,ije,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) +c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) + + + RETURN + END + + + SUBROUTINE vly_loc(q,pente_max,masse,masse_adv_v) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + REAL masse(ijb_u:ije_u,llm),pente_max + REAL masse_adv_v( ijb_v:ije_v,llm) + REAL q(ijb_u:ije_u,llm), dq( ijb_u:ije_u,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL airej2,airejjm,airescb(iim),airesch(iim) + REAL dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v),zdvm(ijb_u:ije_u,llm) + REAL adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u) + REAL qbyv(ijb_v:ije_v,llm) + + REAL qpns,qpsn,apn,aps,dyn1,dys1,dyn2,dys2,newmasse,fn,fs +c REAL newq,oldmasse + Logical extremum,first,testcpu + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 +c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5) + SAVE first,testcpu +c$OMP THREADPRIVATE(first,testcpu) + + REAL convpn,convps,convmpn,convmps + real massepn,masseps,qpn,qps + REAL sinlon(iip1),sinlondlon(iip1) + REAL coslon(iip1),coslondlon(iip1) + SAVE sinlon,coslon,sinlondlon,coslondlon +c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon) + SAVE airej2,airejjm +c$OMP THREADPRIVATE(airej2,airejjm) +c +c + REAL SSUM + EXTERNAL SSUM + + DATA first,testcpu/.true.,.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + INTEGER ijb,ije + + IF(first) THEN +c PRINT*,'Shema Amont nouveau appele dans Vanleer ' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + ENDDO + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + ENDIF + +c +c PRINT*,'CALCUL EN LATITUDE' + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + if (pole_nord) then + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + endif + + if (pole_sud) then + DO i = 1, iim + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpsn = SSUM( iim, airesch ,1 ) / airejjm + endif + + + +c calcul des pentes aux points v + + ijb=ij_begin-2*iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + +c calcul des pentes aux points scalaires + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + ENDDO + +c calcul des pentes aux poles + IF (pole_nord) THEN + DO ij=1,iip1 + dyq(ij,l)=qpns-q(ij+iip1,l) + ENDDO + + dyn1=0. + dyn2=0. + DO ij=1,iim + dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) + dyn2=dyn2+coslondlon(ij)*dyq(ij,l) + ENDDO + DO ij=1,iip1 + dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) + ENDDO + + DO ij=1,iip1 + dyq(ij,l)=0. + ENDDO +c ym tout cela ne sert pas a grand chose + ENDIF + + IF (pole_sud) THEN + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn + ENDDO + + dys1=0. + dys2=0. + + DO ij=1,iim + dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) + dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=0. + ENDDO +c ym tout cela ne sert pas a grand chose + ENDIF + +c filtrage de la derivee + +c calcul des pentes limites aux poles +c ym partie inutile +c goto 8888 +c fn=1. +c fs=1. +c DO ij=1,iim +c IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN +c fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) +c ENDIF +c IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN +c fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) +c ENDIF +c ENDDO +c DO ij=1,iip1 +c dyq(ij,l)=fn*dyq(ij,l) +c dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) +c ENDDO +c 8888 continue + + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C En memoire de dIFferents tests sur la +C limitation des pentes aux poles. +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C PRINT*,dyq(1) +C PRINT*,dyqv(iip1+1) +C apn=abs(dyq(1)/dyqv(iip1+1)) +C PRINT*,dyq(ip1jm+1) +C PRINT*,dyqv(ip1jm-iip1+1) +C aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +C DO ij=2,iim +C apn=amax1(abs(dyq(ij)/dyqv(ij)),apn) +C aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps) +C ENDDO +C apn=min(pente_max/apn,1.) +C aps=min(pente_max/aps,1.) +C +C +C cas ou on a un extremum au pole +C +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & apn=0. +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C & aps=0. +C +C limitation des pentes aux poles +C DO ij=1,iip1 +C dyq(ij)=apn*dyq(ij) +C dyq(ip1jm+ij)=aps*dyq(ip1jm+ij) +C ENDDO +C +C test +C DO ij=1,iip1 +C dyq(iip1+ij)=0. +C dyq(ip1jm+ij-iip1)=0. +C ENDDO +C DO ij=1,ip1jmp1 +C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +C ENDDO +C +C changement 10 07 96 +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & THEN +C DO ij=1,iip1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=1,iip1 +C dyqmax(ij)=pente_max*abs(dyqv(ij)) +C ENDDO +C ENDIF +C +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C &THEN +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) +C ENDDO +C ENDIF +C fin changement 10 07 96 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +c calcul des pentes limitees + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN + dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) + ELSE + dyq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + IF(masse_adv_v(ij,l).gt.0) THEN + qbyv(ij,l)=q(ij+iip1,l)+dyq(ij+iip1,l)* + , 0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l)) + ELSE + qbyv(ij,l)=q(ij,l)-dyq(ij,l)* + , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) + ENDIF + qbyv(ij,l)=masse_adv_v(ij,l)*qbyv(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + newmasse=masse(ij,l) + & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) + + q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO +c.-. ancienne version +c convpn=SSUM(iim,qbyv(1,l),1)/apoln +c convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln + if (pole_nord) then + convpn=SSUM(iim,qbyv(1,l),1) + convmpn=ssum(iim,masse_adv_v(1,l),1) + massepn=ssum(iim,masse(1,l),1) + qpn=0. + do ij=1,iim + qpn=qpn+masse(ij,l)*q(ij,l) + enddo + qpn=(qpn+convpn)/(massepn+convmpn) + do ij=1,iip1 + q(ij,l)=qpn + enddo + endif + +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1)/apols +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1)/apols + + if (pole_sud) then + + convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) + convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) + masseps=ssum(iim, masse(ip1jm+1,l),1) + qps=0. + do ij = ip1jm+1,ip1jmp1-1 + qps=qps+masse(ij,l)*q(ij,l) + enddo + qps=(qps+convps)/(masseps+convmps) + do ij=ip1jm+1,ip1jmp1 + q(ij,l)=qps + enddo + endif +c.-. fin ancienne version + +c._. nouvelle version +c convpn=SSUM(iim,qbyv(1,l),1) +c convmpn=ssum(iim,masse_adv_v(1,l),1) +c oldmasse=ssum(iim,masse(1,l),1) +c newmasse=oldmasse+convmpn +c newq=(q(1,l)*oldmasse+convpn)/newmasse +c newmasse=newmasse/apoln +c DO ij = 1,iip1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) +c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) +c newmasse=oldmasse+convmps +c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse +c newmasse=newmasse/apols +c DO ij = ip1jm+1,ip1jmp1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c._. fin nouvelle version + ENDDO +c$OMP END DO NOWAIT + + RETURN + END + + + + SUBROUTINE vlz_loc(q,pente_max,masse,w,ijb_x,ije_x) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c dq sont des arguments de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + USE Parallel + USE vlz_mod + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ijb_u:ije_u,llm),pente_max + REAL q(ijb_u:ije_u,llm) + REAL w(ijb_u:ije_u,llm+1) +c +c Local +c --------- +c + INTEGER i,ij,l,j,ii +c + REAL newmasse + + REAL dzqmax + REAL sigw + + LOGICAL testcpu + SAVE testcpu +c$OMP THREADPRIVATE(testcpu) + REAL temps0,temps1,temps2,temps3,temps4,temps5,second + SAVE temps0,temps1,temps2,temps3,temps4,temps5 +c$OMP THREADPRIVATE(temps0,temps1,temps2,temps3,temps4,temps5) + + REAL SSUM + EXTERNAL SSUM + + DATA testcpu/.false./ + DATA temps0,temps1,temps2,temps3,temps4,temps5/0.,0.,0.,0.,0.,0./ + INTEGER ijb,ije,ijb_x,ije_x + LOGICAL,SAVE :: first=.TRUE. +!$OMP THREADPRIVATE(first) + + + IF (first) THEN + first=.FALSE. + ENDIF +c On oriente tout dans le sens de la pression c'est a dire dans le +c sens de W + +#ifdef BIDON + IF(testcpu) THEN + temps0=second(0.) + ENDIF +#endif + + ijb=ijb_x + ije=ije_x + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=2,llm + DO ij=ijb,ije + dzqw(ij,l)=q(ij,l-1)-q(ij,l) + adzqw(ij,l)=abs(dzqw(ij,l)) + ENDDO + ENDDO +c$OMP END DO + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=2,llm-1 + DO ij=ijb,ije +#ifdef CRAY + dzq(ij,l)=0.5* + , cvmgp(dzqw(ij,l)+dzqw(ij,l+1),0.,dzqw(ij,l)*dzqw(ij,l+1)) +#else + IF(dzqw(ij,l)*dzqw(ij,l+1).gt.0.) THEN + dzq(ij,l)=0.5*(dzqw(ij,l)+dzqw(ij,l+1)) + ELSE + dzq(ij,l)=0. + ENDIF +#endif + dzqmax=pente_max*min(adzqw(ij,l),adzqw(ij,l+1)) + dzq(ij,l)=sign(min(abs(dzq(ij,l)),dzqmax),dzq(ij,l)) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij=ijb,ije + dzq(ij,1)=0. + dzq(ij,llm)=0. + ENDDO +c$OMP END MASTER +c$OMP BARRIER +#ifdef BIDON + IF(testcpu) THEN + temps1=temps1+second(0.)-temps0 + ENDIF +#endif +c --------------------------------------------------------------- +c .... calcul des termes d'advection verticale ....... +c --------------------------------------------------------------- + +c calcul de - d( q * w )/ d(sigma) qu'on ajoute a dq pour calculer dq + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1,llm-1 + do ij = ijb,ije + IF(w(ij,l+1).gt.0.) THEN + sigw=w(ij,l+1)/masse(ij,l+1) + wq(ij,l+1)=w(ij,l+1)*(q(ij,l+1)+0.5*(1.-sigw)*dzq(ij,l+1)) + ELSE + sigw=w(ij,l+1)/masse(ij,l) + wq(ij,l+1)=w(ij,l+1)*(q(ij,l)-0.5*(1.+sigw)*dzq(ij,l)) + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij=ijb,ije + wq(ij,llm+1)=0. + wq(ij,1)=0. + ENDDO +c$OMP END MASTER +c$OMP BARRIER + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + newmasse=masse(ij,l)+w(ij,l+1)-w(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+wq(ij,l+1)-wq(ij,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO + ENDDO +c$OMP END DO NOWAIT + + + RETURN + END +c SUBROUTINE minmaxq(zq,qmin,qmax,comment) +c +c#include "dimensions.h" +c#include "paramet.h" + +c CHARACTER*(*) comment +c real qmin,qmax +c real zq(ip1jmp1,llm) + +c INTEGER jadrs(ip1jmp1), jbad, k, i + + +c DO k = 1, llm +c jbad = 0 +c DO i = 1, ip1jmp1 +c IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN +c jbad = jbad + 1 +c jadrs(jbad) = i +c ENDIF +c ENDDO +c IF (jbad.GT.0) THEN +c PRINT*, comment +c DO i = 1, jbad +cc PRINT*, "i,k,zq=", jadrs(i),k,zq(jadrs(i),k) +c ENDDO +c ENDIF +c ENDDO + +c return +c end + + + + Index: /LMDZ5/trunk/libf/dyn3dmem/vlspltgen_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/vlspltgen_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/vlspltgen_loc.F (revision 1632) @@ -0,0 +1,518 @@ +! +! $Header$ +! + SUBROUTINE vlspltgen_loc( q,iadv,pente_max,masse,w,pbaru,pbarv, + & pdt, p,pk,teta ) + +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget, F.Codron +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c + test sur humidite specifique: Q advecte< Qsat aval +c (F. Codron, 10/99) +c ******************************************************************** +c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... +c +c pente_max facteur de limitation des pentes: 2 en general +c 0 pour un schema amont +c pbaru,pbarv,w flux de masse en u ,v ,w +c pdt pas de temps +c +c teta temperature potentielle, p pression aux interfaces, +c pk exner au milieu des couches necessaire pour calculer Qsat +c -------------------------------------------------------------------- + USE parallel + USE mod_hallo + USE Write_Field_loc + USE VAMPIR + USE infotrac, ONLY : nqtot + USE vlspltgen_mod + IMPLICIT NONE + +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" + +c +c Arguments: +c ---------- + INTEGER iadv(nqtot) + REAL masse(ijb_u:ije_u,llm),pente_max + REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm) + REAL q(ijb_u:ije_u,llm,nqtot) + REAL w(ijb_u:ije_u,llm),pdt + REAL p(ijb_u:ije_u,llmp1),teta(ijb_u:ije_u,llm) + REAL pk(ijb_u:ije_u,llm) +c +c Local +c --------- +c + INTEGER ij,l +c + REAL zzpbar, zzw + + REAL qmin,qmax + DATA qmin,qmax/0.,1.e33/ + +c--pour rapport de melange saturant-- + + REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play + REAL ptarg,pdelarg,foeew,zdelta + REAL tempe(ijb_u:ije_u) + INTEGER ijb,ije,iq + LOGICAL, SAVE :: firstcall=.TRUE. +!$OMP THREADPRIVATE(firstcall) + type(request) :: MyRequest1 + type(request) :: MyRequest2 + +c fonction psat(T) + + FOEEW ( PTARG,PDELARG ) = EXP ( + * (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT) + * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) ) + + r2es = 380.11733 + r3les = 17.269 + r3ies = 21.875 + r4les = 35.86 + r4ies = 7.66 + retv = 0.6077667 + rtt = 273.16 + +c Allocate variables depending on dynamic variable nqtot + + IF (firstcall) THEN + firstcall=.FALSE. + END IF +c-- Calcul de Qsat en chaque point +c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2 +c pour eviter une exponentielle. + + call SetTag(MyRequest1,100) + call SetTag(MyRequest2,101) + + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij = ijb, ije + tempe(ij) = teta(ij,l) * pk(ij,l) /cpp + ENDDO + DO ij = ijb, ije + zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) ) + play = 0.5*(p(ij,l)+p(ij,l+1)) + qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play ) + qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) ) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c PRINT*,'Debut vlsplt version debug sans vlyqs' + + zzpbar = 0.5 * pdt + zzw = pdt + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ijb+iip1 + if (pole_sud) ije=ije-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij = ijb,ije + mu(ij,l)=pbaru(ij,l) * zzpbar + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + mv(ij,l)=pbarv(ij,l) * zzpbar + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + mw(ij,l)=w(ij,l) * zzw + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP MASTER + DO ij=ijb,ije + mw(ij,llm+1)=0. + ENDDO +c$OMP END MASTER + +c CALL SCOPY(ijp1llm,q,1,zq,1) +c CALL SCOPY(ijp1llm,masse,1,zm,1) + + ijb=ij_begin + ije=ij_end + + DO iq=1,nqtot +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + zq(ijb:ije,l,iq)=q(ijb:ije,l,iq) + zm(ijb:ije,l,iq)=masse(ijb:ije,l) + ENDDO +c$OMP END DO NOWAIT + ENDDO + +#ifdef DEBUG_IO + CALL WriteField_u('mu',mu) + CALL WriteField_v('mv',mv) + CALL WriteField_u('mw',mw) + CALL WriteField_u('qsat',qsat) +#endif + +c$OMP BARRIER + DO iq=1,nqtot + +#ifdef DEBUG_IO + CALL WriteField_u('zq',zq(:,:,iq)) + CALL WriteField_u('zm',zm(:,:,iq)) +#endif + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + +#ifdef _ADV_HALO + call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu, + & ij_begin,ij_begin+2*iip1-1) + call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu, + & ij_end-2*iip1+1,ij_end) +#else + call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu, + & ij_begin,ij_end) +#endif + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1) + call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER + else if (iadv(iq)==14) then + +#ifdef _ADV_HALO + call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu, + & qsat,ij_begin,ij_begin+2*iip1-1) + call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu, + & qsat,ij_end-2*iip1+1,ij_end) +#else + + call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu, + & qsat,ij_begin,ij_end) +#endif + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1) + call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + +c$OMP BARRIER +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call SendRequest(MyRequest1) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + +#ifdef _ADV_HALLO + call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu, + & ij_begin+2*iip1,ij_end-2*iip1) +#endif + else if (iadv(iq)==14) then +#ifdef _ADV_HALLO + call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu, + & qsat,ij_begin+2*iip1,ij_end-2*iip1) +#endif + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo +c$OMP BARRIER +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + +! call WaitRecvRequest(MyRequest1) +! call WaitSendRequest(MyRequest1) +c$OMP BARRIER + call WaitRequest(MyRequest1) + + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + + + do iq=1,nqtot +#ifdef DEBUG_IO + CALL WriteField_u('zq',zq(:,:,iq)) + CALL WriteField_u('zm',zm(:,:,iq)) +#endif + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + + call vly_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv) + + else if (iadv(iq)==14) then + + call vlyqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv, + & qsat) + + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + + do iq=1,nqtot +#ifdef DEBUG_IO + CALL WriteField_u('zq',zq(:,:,iq)) + CALL WriteField_u('zm',zm(:,:,iq)) +#endif + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10 .or. iadv(iq)==14 ) then + +c$OMP BARRIER +#ifdef _ADV_HALLO + call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw, + & ij_begin,ij_begin+2*iip1-1) + call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw, + & ij_end-2*iip1+1,ij_end) +#else + call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw, + & ij_begin,ij_end) +#endif +c$OMP BARRIER + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2) + call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo +c$OMP BARRIER + +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + + call SendRequest(MyRequest2) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER + +c$OMP BARRIER + do iq=1,nqtot + + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10 .or. iadv(iq)==14 ) then +c$OMP BARRIER + +#ifdef _ADV_HALLO + call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw, + & ij_begin+2*iip1,ij_end-2*iip1) +#endif + +c$OMP BARRIER + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + +c$OMP BARRIER +c$OMP MASTER + call VTb(VTHallo) +c$OMP END MASTER + +! call WaitRecvRequest(MyRequest2) +! call WaitSendRequest(MyRequest2) +c$OMP BARRIER + CALL WaitRequest(MyRequest2) + +c$OMP MASTER + call VTe(VTHallo) +c$OMP END MASTER +c$OMP BARRIER + + + do iq=1,nqtot +#ifdef DEBUG_IO + CALL WriteField_u('zq',zq(:,:,iq)) + CALL WriteField_u('zm',zm(:,:,iq)) +#endif + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + + call vly_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv) + + else if (iadv(iq)==14) then + + call vlyqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv, + & qsat) + + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + + do iq=1,nqtot +#ifdef DEBUG_IO + CALL WriteField_u('zq',zq(:,:,iq)) + CALL WriteField_u('zm',zm(:,:,iq)) +#endif + if(iadv(iq) == 0) then + + cycle + + else if (iadv(iq)==10) then + + call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu, + & ij_begin,ij_end) + + else if (iadv(iq)==14) then + + call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu, + & qsat, ij_begin,ij_end) + + else + + stop 'vlspltgen_p : schema non parallelise' + + endif + + enddo + + + ijb=ij_begin + ije=ij_end +c$OMP BARRIER + + + DO iq=1,nqtot +#ifdef DEBUG_IO + CALL WriteField_u('zq',zq(:,:,iq)) + CALL WriteField_u('zm',zm(:,:,iq)) +#endif +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije +c print *,'zq-->',ij,l,iq,zq(ij,l,iq) +c print *,'q-->',ij,l,iq,q(ij,l,iq) + q(ij,l,iq)=zq(ij,l,iq) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-iip1+1,iip1 + q(ij+iim,l,iq)=q(ij,l,iq) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ENDDO + + +c$OMP BARRIER + +cc$OMP MASTER +c call WaitSendRequest(MyRequest1) +c call WaitSendRequest(MyRequest2) +cc$OMP END MASTER +cc$OMP BARRIER + + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/vlspltgen_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/vlspltgen_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/vlspltgen_mod.F90 (revision 1632) @@ -0,0 +1,54 @@ +MODULE vlspltgen_mod + + REAL,POINTER,SAVE :: qsat(:,:) + REAL,POINTER,SAVE :: mu(:,:) + REAL,POINTER,SAVE :: mv(:,:) + REAL,POINTER,SAVE :: mw(:,:) + REAL,POINTER,SAVE :: zm(:,:,:) + REAL,POINTER,SAVE :: zq(:,:,:) + +CONTAINS + + SUBROUTINE vlspltgen_allocate + USE bands + USE allocate_field + USE parallel + USE infotrac + USE vlz_mod,ONLY : vlz_allocate + IMPLICIT NONE + INCLUDE "dimensions.h" + INCLUDE "paramet.h" + TYPE(distrib),POINTER :: d + + d=>distrib_vanleer + CALL allocate_u(qsat,llm,d) + CALL allocate_u(mu,llm,d) + CALL allocate_v(mv,llm,d) + CALL allocate_u(mw,llm+1,d) + CALL allocate_u(zm,llm,nqtot,d) + CALL allocate_u(zq,llm,nqtot,d) + + CALL vlz_allocate + + END SUBROUTINE vlspltgen_allocate + + SUBROUTINE vlspltgen_switch_vanleer(dist) + USE allocate_field + USE bands + USE parallel + USE vlz_mod,ONLY : vlz_switch_vanleer + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(qsat,distrib_vanleer,dist) + CALL switch_u(mu,distrib_vanleer,dist) + CALL switch_u(mv,distrib_vanleer,dist) + CALL switch_u(mw,distrib_vanleer,dist) + CALL switch_u(zm,distrib_vanleer,dist) + CALL switch_u(zq,distrib_vanleer,dist) + + CALL vlz_switch_vanleer(dist) + + END SUBROUTINE vlspltgen_switch_vanleer + +END MODULE vlspltgen_mod Index: /LMDZ5/trunk/libf/dyn3dmem/vlspltqs_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/vlspltqs_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/vlspltqs_loc.F (revision 1632) @@ -0,0 +1,717 @@ + SUBROUTINE vlxqs_loc(q,pente_max,masse,u_m,qsat,ijb_x,ije_x) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c +c -------------------------------------------------------------------- + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +c +c +c Arguments: +c ---------- + REAL masse(ijb_u:ije_u,llm),pente_max + REAL u_m( ijb_u:ije_u,llm ) + REAL q(ijb_u:ije_u,llm) + REAL qsat(ijb_u:ije_u,llm) +c +c Local +c --------- +c + INTEGER ij,l,j,i,iju,ijq,indu(ijnb_u),niju + INTEGER n0,iadvplus(ijb_u:ije_u,llm),nl(llm) +c + REAL new_m,zu_m,zdum(ijb_u:ije_u,llm) + REAL dxq(ijb_u:ije_u,llm),dxqu(ijb_u:ije_u) + REAL zz(ijb_u:ije_u) + REAL adxqu(ijb_u:ije_u),dxqmax(ijb_u:ije_u,llm) + REAL u_mq(ijb_u:ije_u,llm) + + REAL SSUM + + + INTEGER ijb,ije,ijb_x,ije_x + + +c calcul de la pente a droite et a gauche de la maille + +c ijb=ij_begin +c ije=ij_end + + ijb=ijb_x + ije=ije_x + + if (pole_nord.and.ijb==1) ijb=ijb+iip1 + if (pole_sud.and.ije==ip1jmp1) ije=ije-iip1 + + IF (pente_max.gt.-1.e-5) THEN +c IF (pente_max.gt.10) THEN + +c calcul des pentes avec limitation, Van Leer scheme I: +c ----------------------------------------------------- + +c calcul de la pente aux points u + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) +c IF(u_m(ij,l).lt.0.) stop'limx n admet pas les U<0' +c sigu(ij)=u_m(ij,l)/masse(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) +c sigu(ij)=sigu(ij-iim) + ENDDO + + DO ij=ijb,ije + adxqu(ij)=abs(dxqu(ij)) + ENDDO + +c calcul de la pente maximum dans la maille en valeur absolue + + DO ij=ijb+1,ije + dxqmax(ij,l)=pente_max* + , min(adxqu(ij-1),adxqu(ij)) +c limitation subtile +c , min(adxqu(ij-1)/sigu(ij-1),adxqu(ij)/(1.-sigu(ij))) + + + ENDDO + + DO ij=ijb+iip1-1,ije,iip1 + dxqmax(ij-iim,l)=dxqmax(ij,l) + ENDDO + + DO ij=ijb+1,ije +#ifdef CRAY + dxq(ij,l)= + , cvmgp(dxqu(ij-1)+dxqu(ij),0.,dxqu(ij-1)*dxqu(ij)) +#else + IF(dxqu(ij-1)*dxqu(ij).gt.0) THEN + dxq(ij,l)=dxqu(ij-1)+dxqu(ij) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF +#endif + dxq(ij,l)=0.5*dxq(ij,l) + dxq(ij,l)= + , sign(min(abs(dxq(ij,l)),dxqmax(ij,l)),dxq(ij,l)) + ENDDO + + ENDDO ! l=1,llm +c$OMP END DO NOWAIT + + ELSE ! (pente_max.lt.-1.e-5) + +c Pentes produits: +c ---------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm + DO ij=ijb,ije-1 + dxqu(ij)=q(ij+1,l)-q(ij,l) + ENDDO + DO ij=ijb+iip1-1,ije,iip1 + dxqu(ij)=dxqu(ij-iim) + ENDDO + + DO ij=ijb+1,ije + zz(ij)=dxqu(ij-1)*dxqu(ij) + zz(ij)=zz(ij)+zz(ij) + IF(zz(ij).gt.0) THEN + dxq(ij,l)=zz(ij)/(dxqu(ij-1)+dxqu(ij)) + ELSE +c extremum local + dxq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + ENDIF ! (pente_max.lt.-1.e-5) + +c bouclage de la pente en iip1: +c ----------------------------- +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + dxq(ij-iim,l)=dxq(ij,l) + ENDDO + + DO ij=ijb,ije + iadvplus(ij,l)=0 + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + if (pole_nord) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + iadvplus(1:iip1,l)=0 + ENDDO +c$OMP END DO NOWAIT + endif + + if (pole_sud) THEN +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + iadvplus(ip1jm+1:ip1jmp1,l)=0 + ENDDO +c$OMP END DO NOWAIT + endif + +c calcul des flux a gauche et a droite + +#ifdef CRAY +c--pas encore modification sur Qsat +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + zdum(ij,l)=cvmgp(1.-u_m(ij,l)/masse(ij,l), + , 1.+u_m(ij,l)/masse(ij+1,l), + , u_m(ij,l)) + zdum(ij,l)=0.5*zdum(ij,l) + u_mq(ij,l)=cvmgp( + , q(ij,l)+zdum(ij,l)*dxq(ij,l), + , q(ij+1,l)-zdum(ij,l)*dxq(ij+1,l), + , u_m(ij,l)) + u_mq(ij,l)=u_m(ij,l)*u_mq(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +#else +c on cumule le flux correspondant a toutes les mailles dont la masse +c au travers de la paroi pENDant le pas de temps. +c le rapport de melange de l'air advecte est min(q_vanleer, Qsat_downwind) +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + IF (u_m(ij,l).gt.0.) THEN + zdum(ij,l)=1.-u_m(ij,l)/masse(ij,l) + u_mq(ij,l)=u_m(ij,l)* + $ min(q(ij,l)+0.5*zdum(ij,l)*dxq(ij,l),qsat(ij+1,l)) + ELSE + zdum(ij,l)=1.+u_m(ij,l)/masse(ij+1,l) + u_mq(ij,l)=u_m(ij,l)* + $ min(q(ij+1,l)-0.5*zdum(ij,l)*dxq(ij+1,l),qsat(ij,l)) + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT +#endif + + +c detection des points ou on advecte plus que la masse de la +c maille +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije-1 + IF(zdum(ij,l).lt.0) THEN + iadvplus(ij,l)=1 + u_mq(ij,l)=0. + ENDIF + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + iadvplus(ij,l)=iadvplus(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + + +c traitement special pour le cas ou on advecte en longitude plus que le +c contenu de la maille. +c cette partie est mal vectorisee. + +c pas d'influence de la pression saturante (pour l'instant) + +c calcul du nombre de maille sur lequel on advecte plus que la maille. + + n0=0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + nl(l)=0 + DO ij=ijb,ije + nl(l)=nl(l)+iadvplus(ij,l) + ENDDO + n0=n0+nl(l) + ENDDO +c$OMP END DO NOWAIT + +cym ATTENTION ICI en OpenMP reduction pas forcement nécessaire +cym IF(n0.gt.1) THEN +cym IF(n0.gt.0) THEN +ccc PRINT*,'Nombre de points pour lesquels on advect plus que le' +ccc & ,'contenu de la maille : ',n0 +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + IF(nl(l).gt.0) THEN + iju=0 +c indicage des mailles concernees par le traitement special + DO ij=ijb,ije + IF(iadvplus(ij,l).eq.1.and.mod(ij,iip1).ne.0) THEN + iju=iju+1 + indu(iju)=ij + ENDIF + ENDDO + niju=iju +c PRINT*,'niju,nl',niju,nl(l) + +c traitement des mailles + DO iju=1,niju + ij=indu(iju) + j=(ij-1)/iip1+1 + zu_m=u_m(ij,l) + u_mq(ij,l)=0. + IF(zu_m.gt.0.) THEN + ijq=ij + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)+q(ijq,l)*masse(ijq,l) + zu_m=zu_m-masse(ijq,l) + i=mod(i-2+iim,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m* + & (q(ijq,l)+0.5*(1.-zu_m/masse(ijq,l))*dxq(ijq,l)) + ELSE + ijq=ij+1 + i=ijq-(j-1)*iip1 +c accumulation pour les mailles completements advectees + do while(-zu_m.gt.masse(ijq,l)) + u_mq(ij,l)=u_mq(ij,l)-q(ijq,l)*masse(ijq,l) + zu_m=zu_m+masse(ijq,l) + i=mod(i,iim)+1 + ijq=(j-1)*iip1+i + ENDDO +c ajout de la maille non completement advectee + u_mq(ij,l)=u_mq(ij,l)+zu_m*(q(ijq,l)- + & 0.5*(1.+zu_m/masse(ijq,l))*dxq(ijq,l)) + ENDIF + ENDDO + ENDIF + ENDDO +c$OMP END DO NOWAIT +cym ENDIF ! n0.gt.0 + + + +c bouclage en latitude +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+iip1-1,ije,iip1 + u_mq(ij,l)=u_mq(ij-iim,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + +c calcul des tendances +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb+1,ije + new_m=masse(ij,l)+u_m(ij-1,l)-u_m(ij,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+ + & u_mq(ij-1,l)-u_mq(ij,l)) + & /new_m + masse(ij,l)=new_m + ENDDO +c Modif Fred 22 03 96 correction d'un bug (les scopy ci-dessous) + DO ij=ijb+iip1-1,ije,iip1 + q(ij-iim,l)=q(ij,l) + masse(ij-iim,l)=masse(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT +c CALL SCOPY((jjm-1)*llm,q(iip1+iip1,1),iip1,q(iip2,1),iip1) +c CALL SCOPY((jjm-1)*llm,masse(iip1+iip1,1),iip1,masse(iip2,1),iip1) + + + RETURN + END + SUBROUTINE vlyqs_loc(q,pente_max,masse,masse_adv_v,qsat) +c +c Auteurs: P.Le Van, F.Hourdin, F.Forget +c +c ******************************************************************** +c Shema d'advection " pseudo amont " . +c ******************************************************************** +c q,masse_adv_v,w sont des arguments d'entree pour le s-pg .... +c qsat est un argument de sortie pour le s-pg .... +c +c +c -------------------------------------------------------------------- + USE parallel + IMPLICIT NONE +c +#include "dimensions.h" +#include "paramet.h" +#include "logic.h" +#include "comvert.h" +#include "comconst.h" +#include "comgeom.h" +c +c +c Arguments: +c ---------- + REAL masse(ijb_u:ije_u,llm),pente_max + REAL masse_adv_v( ijb_v:ije_v,llm) + REAL q(ijb_u:ije_u,llm) + REAL qsat(ijb_u:ije_u,llm) +c +c Local +c --------- +c + INTEGER i,ij,l +c + REAL airej2,airejjm,airescb(iim),airesch(iim) + REAL dyq(ijb_u:ije_u,llm),dyqv(ijb_v:ije_v) + REAL adyqv(ijb_v:ije_v),dyqmax(ijb_u:ije_u) + REAL qbyv(ijb_v:ije_v,llm) + + REAL qpns,qpsn,dyn1,dys1,dyn2,dys2,newmasse,fn,fs +c REAL newq,oldmasse + Logical first + SAVE first +c$OMP THREADPRIVATE(first) + REAL convpn,convps,convmpn,convmps + REAL sinlon(iip1),sinlondlon(iip1) + REAL coslon(iip1),coslondlon(iip1) + SAVE sinlon,coslon,sinlondlon,coslondlon + SAVE airej2,airejjm +c$OMP THREADPRIVATE(sinlon,coslon,sinlondlon,coslondlon) +c$OMP THREADPRIVATE(airej2,airejjm) +c +c + REAL SSUM + + DATA first/.true./ + INTEGER ijb,ije + + IF(first) THEN + PRINT*,'Shema Amont nouveau appele dans Vanleer ' + first=.false. + do i=2,iip1 + coslon(i)=cos(rlonv(i)) + sinlon(i)=sin(rlonv(i)) + coslondlon(i)=coslon(i)*(rlonu(i)-rlonu(i-1))/pi + sinlondlon(i)=sinlon(i)*(rlonu(i)-rlonu(i-1))/pi + ENDDO + coslon(1)=coslon(iip1) + coslondlon(1)=coslondlon(iip1) + sinlon(1)=sinlon(iip1) + sinlondlon(1)=sinlondlon(iip1) + airej2 = SSUM( iim, aire(iip2), 1 ) + airejjm= SSUM( iim, aire(ip1jm -iim), 1 ) + ENDIF + +c + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l = 1, llm +c +c -------------------------------- +c CALCUL EN LATITUDE +c -------------------------------- + +c On commence par calculer la valeur du traceur moyenne sur le premier cercle +c de latitude autour du pole (qpns pour le pole nord et qpsn pour +c le pole nord) qui sera utilisee pour evaluer les pentes au pole. + + if (pole_nord) then + DO i = 1, iim + airescb(i) = aire(i+ iip1) * q(i+ iip1,l) + ENDDO + qpns = SSUM( iim, airescb ,1 ) / airej2 + endif + + if (pole_sud) then + DO i = 1, iim + airesch(i) = aire(i+ ip1jm- iip1) * q(i+ ip1jm- iip1,l) + ENDDO + qpsn = SSUM( iim, airesch ,1 ) / airejjm + endif + + +c calcul des pentes aux points v + + ijb=ij_begin-2*iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyqv(ij)=q(ij,l)-q(ij+iip1,l) + adyqv(ij)=abs(dyqv(ij)) + ENDDO + + +c calcul des pentes aux points scalaires + + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + dyq(ij,l)=.5*(dyqv(ij-iip1)+dyqv(ij)) + dyqmax(ij)=min(adyqv(ij-iip1),adyqv(ij)) + dyqmax(ij)=pente_max*dyqmax(ij) + ENDDO + + IF (pole_nord) THEN + +c calcul des pentes aux poles + DO ij=1,iip1 + dyq(ij,l)=qpns-q(ij+iip1,l) + ENDDO + +c filtrage de la derivee + dyn1=0. + dyn2=0. + DO ij=1,iim + dyn1=dyn1+sinlondlon(ij)*dyq(ij,l) + dyn2=dyn2+coslondlon(ij)*dyq(ij,l) + ENDDO + DO ij=1,iip1 + dyq(ij,l)=dyn1*sinlon(ij)+dyn2*coslon(ij) + ENDDO + +c calcul des pentes limites aux poles + fn=1. + DO ij=1,iim + IF(pente_max*adyqv(ij).lt.abs(dyq(ij,l))) THEN + fn=min(pente_max*adyqv(ij)/abs(dyq(ij,l)),fn) + ENDIF + ENDDO + + DO ij=1,iip1 + dyq(ij,l)=fn*dyq(ij,l) + ENDDO + + ENDIF + + IF (pole_sud) THEN + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=q(ip1jm+ij-iip1,l)-qpsn + ENDDO + + dys1=0. + dys2=0. + + DO ij=1,iim + dys1=dys1+sinlondlon(ij)*dyq(ip1jm+ij,l) + dys2=dys2+coslondlon(ij)*dyq(ip1jm+ij,l) + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=dys1*sinlon(ij)+dys2*coslon(ij) + ENDDO + +c calcul des pentes limites aux poles + fs=1. + DO ij=1,iim + IF(pente_max*adyqv(ij+ip1jm-iip1).lt.abs(dyq(ij+ip1jm,l))) THEN + fs=min(pente_max*adyqv(ij+ip1jm-iip1)/abs(dyq(ij+ip1jm,l)),fs) + ENDIF + ENDDO + + DO ij=1,iip1 + dyq(ip1jm+ij,l)=fs*dyq(ip1jm+ij,l) + ENDDO + + ENDIF + + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C En memoire de dIFferents tests sur la +C limitation des pentes aux poles. +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C PRINT*,dyq(1) +C PRINT*,dyqv(iip1+1) +C apn=abs(dyq(1)/dyqv(iip1+1)) +C PRINT*,dyq(ip1jm+1) +C PRINT*,dyqv(ip1jm-iip1+1) +C aps=abs(dyq(ip1jm+1)/dyqv(ip1jm-iip1+1)) +C DO ij=2,iim +C apn=amax1(abs(dyq(ij)/dyqv(ij)),apn) +C aps=amax1(abs(dyq(ip1jm+ij)/dyqv(ip1jm-iip1+ij)),aps) +C ENDDO +C apn=min(pente_max/apn,1.) +C aps=min(pente_max/aps,1.) +C +C +C cas ou on a un extremum au pole +C +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & apn=0. +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C & aps=0. +C +C limitation des pentes aux poles +C DO ij=1,iip1 +C dyq(ij)=apn*dyq(ij) +C dyq(ip1jm+ij)=aps*dyq(ip1jm+ij) +C ENDDO +C +C test +C DO ij=1,iip1 +C dyq(iip1+ij)=0. +C dyq(ip1jm+ij-iip1)=0. +C ENDDO +C DO ij=1,ip1jmp1 +C dyq(ij)=dyq(ij)*cos(rlatu((ij-1)/iip1+1)) +C ENDDO +C +C changement 10 07 96 +C IF(dyqv(ismin(iim,dyqv,1))*dyqv(ismax(iim,dyqv,1)).le.0.) +C & THEN +C DO ij=1,iip1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=1,iip1 +C dyqmax(ij)=pente_max*abs(dyqv(ij)) +C ENDDO +C ENDIF +C +C IF(dyqv(ismax(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1)* +C & dyqv(ismin(iim,dyqv(ip1jm-iip1+1),1)+ip1jm-iip1+1).le.0.) +C &THEN +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=0. +C ENDDO +C ELSE +C DO ij=ip1jm+1,ip1jmp1 +C dyqmax(ij)=pente_max*abs(dyqv(ij-iip1)) +C ENDDO +C ENDIF +C fin changement 10 07 96 +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +c calcul des pentes limitees + ijb=ij_begin-iip1 + ije=ij_end+iip1 + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + + DO ij=ijb,ije + IF(dyqv(ij)*dyqv(ij-iip1).gt.0.) THEN + dyq(ij,l)=sign(min(abs(dyq(ij,l)),dyqmax(ij)),dyq(ij,l)) + ELSE + dyq(ij,l)=0. + ENDIF + ENDDO + + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin-iip1 + ije=ij_end + if (pole_nord) ijb=ij_begin + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + IF( masse_adv_v(ij,l).GT.0. ) THEN + qbyv(ij,l)= MIN( qsat(ij+iip1,l), q(ij+iip1,l ) + + , dyq(ij+iip1,l)*0.5*(1.-masse_adv_v(ij,l)/masse(ij+iip1,l))) + ELSE + qbyv(ij,l)= MIN( qsat(ij,l), q(ij,l) - dyq(ij,l) * + , 0.5*(1.+masse_adv_v(ij,l)/masse(ij,l)) ) + ENDIF + qbyv(ij,l) = masse_adv_v(ij,l)*qbyv(ij,l) + ENDDO + ENDDO +c$OMP END DO NOWAIT + + ijb=ij_begin + ije=ij_end + if (pole_nord) ijb=ij_begin+iip1 + if (pole_sud) ije=ij_end-iip1 + +c$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO l=1,llm + DO ij=ijb,ije + newmasse=masse(ij,l) + & +masse_adv_v(ij,l)-masse_adv_v(ij-iip1,l) + q(ij,l)=(q(ij,l)*masse(ij,l)+qbyv(ij,l)-qbyv(ij-iip1,l)) + & /newmasse + masse(ij,l)=newmasse + ENDDO +c.-. ancienne version + + IF (pole_nord) THEN + + convpn=SSUM(iim,qbyv(1,l),1)/apoln + convmpn=ssum(iim,masse_adv_v(1,l),1)/apoln + DO ij = 1,iip1 + newmasse=masse(ij,l)+convmpn*aire(ij) + q(ij,l)=(q(ij,l)*masse(ij,l)+convpn*aire(ij))/ + & newmasse + masse(ij,l)=newmasse + ENDDO + + ENDIF + + IF (pole_sud) THEN + + convps = -SSUM(iim,qbyv(ip1jm-iim,l),1)/apols + convmps = -SSUM(iim,masse_adv_v(ip1jm-iim,l),1)/apols + DO ij = ip1jm+1,ip1jmp1 + newmasse=masse(ij,l)+convmps*aire(ij) + q(ij,l)=(q(ij,l)*masse(ij,l)+convps*aire(ij))/ + & newmasse + masse(ij,l)=newmasse + ENDDO + + ENDIF +c.-. fin ancienne version + +c._. nouvelle version +c convpn=SSUM(iim,qbyv(1,l),1) +c convmpn=ssum(iim,masse_adv_v(1,l),1) +c oldmasse=ssum(iim,masse(1,l),1) +c newmasse=oldmasse+convmpn +c newq=(q(1,l)*oldmasse+convpn)/newmasse +c newmasse=newmasse/apoln +c DO ij = 1,iip1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c convps=-SSUM(iim,qbyv(ip1jm-iim,l),1) +c convmps=-ssum(iim,masse_adv_v(ip1jm-iim,l),1) +c oldmasse=ssum(iim,masse(ip1jm-iim,l),1) +c newmasse=oldmasse+convmps +c newq=(q(ip1jmp1,l)*oldmasse+convps)/newmasse +c newmasse=newmasse/apols +c DO ij = ip1jm+1,ip1jmp1 +c q(ij,l)=newq +c masse(ij,l)=newmasse*aire(ij) +c ENDDO +c._. fin nouvelle version + ENDDO +c$OMP END DO NOWAIT + RETURN + END Index: /LMDZ5/trunk/libf/dyn3dmem/vlz_mod.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/vlz_mod.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/vlz_mod.F90 (revision 1632) @@ -0,0 +1,41 @@ +MODULE vlz_mod + + REAL,POINTER,SAVE :: wq(:,:) + REAL,POINTER,SAVE :: dzq(:,:) + REAL,POINTER,SAVE :: dzqw(:,:) + REAL,POINTER,SAVE :: adzqw(:,:) + +CONTAINS + + SUBROUTINE vlz_allocate + USE bands + USE allocate_field + USE parallel + USE infotrac + USE dimensions + IMPLICIT NONE + TYPE(distrib),POINTER :: d + + d=>distrib_vanleer + CALL allocate_u(wq,llm+1,d) + CALL allocate_u(dzq,llm,d) + CALL allocate_u(dzqw,llm,d) + CALL allocate_u(adzqw,llm,d) + + END SUBROUTINE vlz_allocate + + SUBROUTINE vlz_switch_vanleer(dist) + USE allocate_field + USE bands + USE parallel + IMPLICIT NONE + TYPE(distrib),INTENT(IN) :: dist + + CALL switch_u(wq,distrib_vanleer,dist) + CALL switch_u(dzq,distrib_vanleer,dist) + CALL switch_u(dzqw,distrib_vanleer,dist) + CALL switch_u(adzqw,distrib_vanleer,dist) + + END SUBROUTINE vlz_switch_vanleer + +END MODULE vlz_mod Index: /LMDZ5/trunk/libf/dyn3dmem/wrgrads.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/wrgrads.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/wrgrads.F (revision 1632) @@ -0,0 +1,128 @@ +! +! $Header$ +! + subroutine wrgrads(if,nl,field,name,titlevar) + implicit none + +c Declarations +c if indice du fichier +c nl nombre de couches +c field champ +c name petit nom +c titlevar Titre + +#include "gradsdef.h" + +c arguments + integer if,nl + real field(imx*jmx*lmx) + character*10 name,file + character*10 titlevar + +c local + + integer im,jm,lm,i,j,l,lnblnk,iv,iii,iji,iif,ijf + + logical writectl + + + writectl=.false. + + print*,if,iid(if),jid(if),ifd(if),jfd(if) + iii=iid(if) + iji=jid(if) + iif=ifd(if) + ijf=jfd(if) + im=iif-iii+1 + jm=ijf-iji+1 + lm=lmd(if) + + print*,'im,jm,lm,name,firsttime(if)' + print*,im,jm,lm,name,firsttime(if) + + if(firsttime(if)) then + if(name.eq.var(1,if)) then + firsttime(if)=.false. + ivar(if)=1 + print*,'fin de l initialiation de l ecriture du fichier' + print*,file + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + else + ivar(if)=ivar(if)+1 + nvar(if)=ivar(if) + var(ivar(if),if)=name + tvar(ivar(if),if)=titlevar(1:lnblnk(titlevar)) + nld(ivar(if),if)=nl + print*,'initialisation ecriture de ',var(ivar(if),if) + print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if) + endif + writectl=.true. + itime(if)=1 + else + ivar(if)=mod(ivar(if),nvar(if))+1 + if (ivar(if).eq.nvar(if)) then + writectl=.true. + itime(if)=itime(if)+1 + endif + + if(var(ivar(if),if).ne.name) then + print*,'Il faut stoker la meme succession de champs a chaque' + print*,'pas de temps' + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + + stop + endif + endif + + print*,'ivar(if),nvar(if),var(ivar(if),if),writectl' + print*,ivar(if),nvar(if),var(ivar(if),if),writectl + do l=1,nl + irec(if)=irec(if)+1 +c print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf, +c s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii +c s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif + write(unit(if)+1,rec=irec(if)) + s ((field((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i) + s ,i=iii,iif),j=iji,ijf) + enddo + if (writectl) then + + file=fichier(if) +c WARNING! on reecrase le fichier .ctl a chaque ecriture + open(unit(if),file=file(1:lnblnk(file))//'.ctl' + & ,form='formatted',status='unknown') + write(unit(if),'(a5,1x,a40)') + & 'DSET ','^'//file(1:lnblnk(file))//'.dat' + + write(unit(if),'(a12)') 'UNDEF 1.0E30' + write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if) + call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF') + call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF') + call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF') + write(unit(if),'(a4,i10,a30)') + & 'TDEF ',itime(if),' LINEAR 02JAN1987 1MO ' + write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if) + do iv=1,nvar(if) +c print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)' +c print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if) + write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if) + & ,99,tvar(iv,if) + enddo + write(unit(if),'(a7)') 'ENDVARS' +c +1000 format(a5,3x,i4,i3,1x,a39) + + close(unit(if)) + + endif ! writectl + + return + + END + Index: /LMDZ5/trunk/libf/dyn3dmem/write_field_loc.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/write_field_loc.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/write_field_loc.F90 (revision 1632) @@ -0,0 +1,153 @@ +module write_field_loc +implicit none + + interface WriteField_u + module procedure Write_field1d_u,Write_Field2d_u + end interface WriteField_u + + interface WriteField_v + module procedure Write_field1d_v,Write_Field2d_v + end interface WriteField_v + + contains + + subroutine write_field1D_u(name,Field) + character(len=*) :: name + real, dimension(:) :: Field + + CALL write_field_u_gen(name,Field,1) + + end subroutine write_field1D_u + + subroutine write_field2D_u(name,Field) + implicit none + + character(len=*) :: name + real, dimension(:,:) :: Field + integer :: ll + + ll=size(field,2) + CALL write_field_u_gen(name,Field,ll) + + end subroutine write_field2D_u + + + SUBROUTINE write_field_u_gen(name,Field,ll) + USE parallel + USE write_field + USE mod_hallo + implicit none + include 'dimensions.h' + include 'paramet.h' + + character(len=*) :: name + real, dimension(ijb_u:ije_u,ll) :: Field + real, allocatable,SAVE :: New_Field(:,:,:) + integer,dimension(0:mpi_size-1) :: jj_nb_master + type(Request) :: Request_write + integer :: ll,i + + + jj_nb_master(:)=0 + jj_nb_master(0)=jjp1 +!$OMP BARRIER +!$OMP MASTER + allocate(New_Field(iip1,jjp1,ll)) +!$OMP END MASTER +!$OMP BARRIER + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO i=1,ll + New_Field(:,jj_begin:jj_end,i)=reshape(Field(ij_begin:ij_end,i),(/iip1,jj_nb/)) + ENDDO + + call Register_SwapField(new_field,new_field,ip1jmp1,ll,jj_Nb_master,Request_write) + call SendRequest(Request_write) +!$OMP BARRIER + call WaitRequest(Request_write) +!$OMP BARRIER + +!$OMP MASTER + if (MPI_Rank==0) call WriteField(name,New_Field) + DEALLOCATE(New_Field) +!$OMP END MASTER +!$OMP BARRIER + END SUBROUTINE write_field_u_gen + + + subroutine write_field1D_v(name,Field) + character(len=*) :: name + real, dimension(:) :: Field + + CALL write_field_v_gen(name,Field,1) + + end subroutine write_field1D_v + + subroutine write_field2D_v(name,Field) + implicit none + + character(len=*) :: name + real, dimension(:,:) :: Field + integer :: ll + + ll=size(field,2) + CALL write_field_v_gen(name,Field,ll) + + end subroutine write_field2D_v + + + SUBROUTINE write_field_v_gen(name,Field,ll) + USE parallel + USE write_field + USE mod_hallo + implicit none + include 'dimensions.h' + include 'paramet.h' + + character(len=*) :: name + real, dimension(ijb_v:ije_v,ll) :: Field + real, allocatable,SAVE :: New_Field(:,:,:) + integer,dimension(0:mpi_size-1) :: jj_nb_master + type(Request) :: Request_write + integer :: ll,i,jje,ije,jjn + + + jj_nb_master(:)=0 + jj_nb_master(0)=jjp1 + +!$OMP BARRIER +!$OMP MASTER + allocate(New_Field(iip1,jjm,ll)) +!$OMP END MASTER +!$OMP BARRIER + + IF (pole_sud) THEN + jje=jj_end-1 + ije=ij_end-iip1 + jjn=jj_nb-1 + ELSE + jje=jj_end + ije=ij_end + jjn=jj_nb + ENDIF + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + DO i=1,ll + New_Field(:,jj_begin:jje,i)=reshape(Field(ij_begin:ije,i),(/iip1,jjn/)) + ENDDO + + call Register_SwapField(new_field,new_field,ip1jm,ll,jj_Nb_master,Request_write) + call SendRequest(Request_write) +!$OMP BARRIER + call WaitRequest(Request_write) +!$OMP BARRIER + +!$OMP MASTER + if (MPI_Rank==0) call WriteField(name,New_Field) + DEALLOCATE(New_Field) +!$OMP END MASTER +!$OMP BARRIER + END SUBROUTINE write_field_v_gen + +end module write_field_loc + Index: /LMDZ5/trunk/libf/dyn3dmem/write_field_p.F90 =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/write_field_p.F90 (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/write_field_p.F90 (revision 1632) @@ -0,0 +1,73 @@ +module write_field_p +implicit none + + interface WriteField_p + module procedure Write_field3d_p,Write_Field2d_p,Write_Field1d_p + end interface WriteField_p + + contains + + subroutine write_field1D_p(name,Field) + USE parallel + USE write_field + implicit none + + integer, parameter :: MaxDim=1 + character(len=*) :: name + real, dimension(:) :: Field + real, dimension(:),allocatable :: New_Field + integer, dimension(MaxDim) :: Dim + + + Dim=shape(Field) + allocate(New_Field(Dim(1))) + New_Field(:)=Field(:) + call Gather_Field(New_Field,dim(1),1,0) + + if (MPI_Rank==0) call WriteField(name,New_Field) + + end subroutine write_field1D_p + + subroutine write_field2D_p(name,Field) + USE parallel + USE write_field + implicit none + + integer, parameter :: MaxDim=2 + character(len=*) :: name + real, dimension(:,:) :: Field + real, dimension(:,:),allocatable :: New_Field + integer, dimension(MaxDim) :: Dim + + Dim=shape(Field) + allocate(New_Field(Dim(1),Dim(2))) + New_Field(:,:)=Field(:,:) + call Gather_Field(New_Field(1,1),dim(1)*dim(2),1,0) + + if (MPI_Rank==0) call WriteField(name,New_Field) + + + end subroutine write_field2D_p + + subroutine write_field3D_p(name,Field) + USE parallel + USE write_field + implicit none + + integer, parameter :: MaxDim=3 + character(len=*) :: name + real, dimension(:,:,:) :: Field + real, dimension(:,:,:),allocatable :: New_Field + integer, dimension(MaxDim) :: Dim + + Dim=shape(Field) + allocate(New_Field(Dim(1),Dim(2),Dim(3))) + New_Field(:,:,:)=Field(:,:,:) + call Gather_Field(New_Field(1,1,1),dim(1)*dim(2),dim(3),0) + + if (MPI_Rank==0) call WriteField(name,New_Field) + + end subroutine write_field3D_p + +end module write_field_p + Index: /LMDZ5/trunk/libf/dyn3dmem/write_grads_dyn.h =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/write_grads_dyn.h (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/write_grads_dyn.h (revision 1632) @@ -0,0 +1,31 @@ +! +! $Header$ +! + if (callinigrads) then + + string10='dyn' + call inigrads(1,iip1 + s ,rlonv,180./pi,-180.,180.,jjp1,rlatu,-90.,90.,180./pi + s ,llm,presnivs,1. + s ,dtvr*iperiod,string10,'dyn_zon ') + + callinigrads=.false. + + + endif + + string10='ps' + CALL wrgrads(1,1,ps,string10,string10) + + string10='u' + CALL wrgrads(1,llm,unat,string10,string10) + string10='v' + CALL wrgrads(1,llm,vnat,string10,string10) + string10='teta' + CALL wrgrads(1,llm,teta,string10,string10) + do iq=1,nqtot + string10='q' + write(string10(2:2),'(i1)') iq + CALL wrgrads(1,llm,q(:,:,iq),string10,string10) + enddo + Index: /LMDZ5/trunk/libf/dyn3dmem/writedynav_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/writedynav_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/writedynav_loc.F (revision 1632) @@ -0,0 +1,224 @@ +! +! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $ +! + subroutine writedynav_loc( time, vcov, ucov,teta,ppk,phi,q, + . masse,ps,phis) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE ioipsl +#endif + USE parallel + USE misc_mod + USE infotrac, ONLY : nqtot, ttext + use com_io_dyn_mod, only : histaveid,histvaveid,histuaveid + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C histid: ID du fichier histoire +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) + REAL teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm) + REAL ppk(ijb_u:ije_u,llm) + REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm) + REAL phis(ijb_u:ije_u) + REAL q(ijb_u:ije_u,llm,nqtot) + integer time + + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:) + INTEGER :: iq, ii, ll + REAL,SAVE,ALLOCATABLE :: tm(:,:) + REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:) + logical ok_sync + integer itau_w + integer :: ijb,ije,jjn + LOGICAL,SAVE :: first=.TRUE. +!$OMP THREADPRIVATE(first) + +C +C Initialisations +C + if (adjust) return + + IF (first) THEN +!$OMP BARRIER +!$OMP MASTER + ALLOCATE(unat(ijb_u:ije_u,llm)) + ALLOCATE(vnat(ijb_u:ije_u,llm)) + ALLOCATE(tm(ijb_u:ije_u,llm)) + ALLOCATE(ndex2d(ijnb_u*llm)) + ALLOCATE(ndexu(ijnb_u*llm)) + ALLOCATE(ndexv(ijnb_v*llm)) + ndex2d = 0 + ndexu = 0 + ndexv = 0 +!$OMP END MASTER +!$OMP BARRIER + first=.FALSE. + ENDIF + + ok_sync = .TRUE. + itau_w = itau_dyn + time + +C Passage aux composantes naturelles du vent + call covnat_loc(llm, ucov, vcov, unat, vnat) + +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U +C + +!$OMP BARRIER +!$OMP MASTER + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(histuaveid, 'u', itau_w, unat(ijb:ije,:), + . iip1*jjn*llm, ndexu) +!$OMP END MASTER + +C +C Vents V +C + +!$OMP BARRIER +!$OMP MASTER + call histwrite(histvaveid, 'v', itau_w, vnat(ijb:ije,:), + . iip1*jjn*llm, ndexv) +!$OMP END MASTER + + +C +C Temperature potentielle moyennee +C +!$OMP MASTER + call histwrite(histaveid, 'theta', itau_w, teta(ijb:ije,:), + . iip1*jjn*llm, ndexu) +!$OMP END MASTER + +C +C Temperature moyennee +C + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do ll=1,llm + do ii = ijb, ije + tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp + enddo + enddo +!$OMP ENDDO + +!$OMP MASTER + call histwrite(histaveid, 'temp', itau_w, tm(ijb:ije,:), + . iip1*jjn*llm, ndexu) +!$OMP END MASTER + + +C +C Geopotentiel +C +!$OMP MASTER + call histwrite(histaveid, 'phi', itau_w, phi(ijb:ije,:), + . iip1*jjn*llm, ndexu) +!$OMP END MASTER + + +C +C Traceurs +C +!!$OMP MASTER +! DO iq=1,nqtot +! call histwrite(histaveid, ttext(iq), itau_w, q(ijb:ije,:,iq), +! . iip1*jjn*llm, ndexu) +! enddo +!!$OMP END MASTER + + +C +C Masse +C +!$OMP MASTER + call histwrite(histaveid, 'masse', itau_w, masse(ijb:ije,:), + . iip1*jjn, ndexu) +!$OMP END MASTER + + +C +C Pression au sol +C +!$OMP MASTER + + call histwrite(histaveid, 'ps', itau_w, ps(ijb:ije), + . iip1*jjn, ndex2d) +!$OMP END MASTER + +C +C Geopotentiel au sol +C +!$OMP MASTER + call histwrite(histaveid, 'phis', itau_w, phis(ijb:ije), + . iip1*jjn, ndexu) +!$OMP END MASTER + +C +C Fin +C +!$OMP MASTER + if (ok_sync) then + call histsync(histaveid) + call histsync(histvaveid) + call histsync(histuaveid) + ENDIF +!$OMP END MASTER +#else + write(lunout,*)'writedynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/writedynav_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/writedynav_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/writedynav_p.F (revision 1632) @@ -0,0 +1,169 @@ +! +! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $ +! + subroutine writedynav_p( histid, time, vcov, + , ucov,teta,ppk,phi,q,masse,ps,phis) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE ioipsl +#endif + USE parallel + USE misc_mod + USE infotrac + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C histid: ID du fichier histoire +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + INTEGER histid + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm),ppk(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL phis(ip1jmp1) + REAL q(ip1jmp1,llm,nqtot) + integer time + + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer ndex2d(iip1*jjp1),ndex3d(iip1*jjp1*llm),iq, ii, ll + real us(ip1jmp1,llm), vs(ip1jmp1,llm) + real tm(ip1jmp1,llm) + REAL vnat(ip1jm,llm),unat(ip1jmp1,llm) + logical ok_sync + integer itau_w + integer :: ijb,ije,jjn +C +C Initialisations +C + if (adjust) return + + ndex3d = 0 + ndex2d = 0 + ok_sync = .TRUE. + us = 999.999 + vs = 999.999 + tm = 999.999 + vnat = 999.999 + unat = 999.999 + itau_w = itau_dyn + time + +C Passage aux composantes naturelles du vent + call covnat_p(llm, ucov, vcov, unat, vnat) + +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U scalaire +C + call gr_u_scal_p(llm, unat, us) + + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(histid, 'u', itau_w, us(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Vents V scalaire +C + + call gr_v_scal_p(llm, vnat, vs) + call histwrite(histid, 'v', itau_w, vs(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Temperature potentielle moyennee +C + + call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Temperature moyennee +C + do ll=1,llm + do ii = ijb, ije + tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp + enddo + enddo + + call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Geopotentiel +C + call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), + . iip1*jjn*llm, ndex3d) +C +C Traceurs +C + DO iq=1,nqtot + call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), + . iip1*jjn*llm, ndex3d) + enddo +C +C Masse +C + call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1), + . iip1*jjn, ndex2d) +C +C Pression au sol +C + call histwrite(histid, 'ps', itau_w, ps(ijb:ije), + . iip1*jjn, ndex2d) +C +C Geopotentiel au sol +C + call histwrite(histid, 'phis', itau_w, phis(ijb:ije), + . iip1*jjn, ndex2d) +C +C Fin +C + if (ok_sync) call histsync(histid) +#else + write(lunout,*)'writedynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/writehist_loc.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/writehist_loc.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/writehist_loc.F (revision 1632) @@ -0,0 +1,224 @@ +! +! $Id: writedynav_p.F 1279 2009-12-10 09:02:56Z fairhead $ +! + subroutine writehist_loc( time, vcov, ucov,teta,ppk,phi,q, + . masse,ps,phis) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE ioipsl +#endif + USE parallel + USE misc_mod + USE infotrac, ONLY : nqtot, ttext + use com_io_dyn_mod, only : histid,histvid,histuid + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C histid: ID du fichier histoire +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm) + REAL teta(ijb_u:ije_u,llm),phi(ijb_u:ije_u,llm) + REAL ppk(ijb_u:ije_u,llm) + REAL ps(ijb_u:ije_u),masse(ijb_u:ije_u,llm) + REAL phis(ijb_u:ije_u) + REAL q(ijb_u:ije_u,llm,nqtot) + integer time + + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + INTEGER,SAVE,ALLOCATABLE :: ndex2d(:),ndexu(:),ndexv(:) + INTEGER :: iq, ii, ll + REAL,SAVE,ALLOCATABLE :: tm(:,:) + REAL,SAVE,ALLOCATABLE :: vnat(:,:),unat(:,:) + logical ok_sync + integer itau_w + integer :: ijb,ije,jjn + LOGICAL,SAVE :: first=.TRUE. +!$OMP THREADPRIVATE(first) + +C +C Initialisations +C + if (adjust) return + + IF (first) THEN +!$OMP BARRIER +!$OMP MASTER + ALLOCATE(unat(ijb_u:ije_u,llm)) + ALLOCATE(vnat(ijb_u:ije_u,llm)) + ALLOCATE(tm(ijb_u:ije_u,llm)) + ALLOCATE(ndex2d(ijnb_u*llm)) + ALLOCATE(ndexu(ijnb_u*llm)) + ALLOCATE(ndexv(ijnb_v*llm)) + ndex2d = 0 + ndexu = 0 + ndexv = 0 +!$OMP END MASTER +!$OMP BARRIER + first=.FALSE. + ENDIF + + ok_sync = .TRUE. + itau_w = itau_dyn + time + +C Passage aux composantes naturelles du vent + call covnat_loc(llm, ucov, vcov, unat, vnat) + +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U +C + +!$OMP BARRIER +!$OMP MASTER + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(histuid, 'u', itau_w, unat(ijb:ije,:), + . iip1*jjn*llm, ndexu) +!$OMP END MASTER + +C +C Vents V +C + +!$OMP BARRIER +!$OMP MASTER + call histwrite(histvid, 'v', itau_w, vnat(ijb:ije,:), + . iip1*jjn*llm, ndexv) +!$OMP END MASTER + + +C +C Temperature potentielle moyennee +C +!$OMP MASTER + call histwrite(histid, 'theta', itau_w, teta(ijb:ije,:), + . iip1*jjn*llm, ndexu) +!$OMP END MASTER + +C +C Temperature moyennee +C + +!$OMP DO SCHEDULE(STATIC,OMP_CHUNK) + do ll=1,llm + do ii = ijb, ije + tm(ii,ll) = teta(ii,ll) * ppk(ii,ll)/cpp + enddo + enddo +!$OMP ENDDO + +!$OMP MASTER + call histwrite(histid, 'temp', itau_w, tm(ijb:ije,:), + . iip1*jjn*llm, ndexu) +!$OMP END MASTER + + +C +C Geopotentiel +C +!$OMP MASTER + call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), + . iip1*jjn*llm, ndexu) +!$OMP END MASTER + + +C +C Traceurs +C +!!$OMP MASTER +! DO iq=1,nqtot +! call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), +! . iip1*jjn*llm, ndexu) +! enddo +!!$OMP END MASTER + + +C +C Masse +C +!$OMP MASTER + call histwrite(histid, 'masse', itau_w, masse(ijb:ije,:), + . iip1*jjn, ndexu) +!$OMP END MASTER + + +C +C Pression au sol +C +!$OMP MASTER + + call histwrite(histid, 'ps', itau_w, ps(ijb:ije), + . iip1*jjn, ndex2d) +!$OMP END MASTER + +C +C Geopotentiel au sol +C +!$OMP MASTER + call histwrite(histid, 'phis', itau_w, phis(ijb:ije), + . iip1*jjn, ndexu) +!$OMP END MASTER + +C +C Fin +C +!$OMP MASTER + if (ok_sync) then + call histsync(histid) + call histsync(histvid) + call histsync(histuid) + endif +!$OMP END MASTER +#else + write(lunout,*)'writedynav_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end Index: /LMDZ5/trunk/libf/dyn3dmem/writehist_p.F =================================================================== --- /LMDZ5/trunk/libf/dyn3dmem/writehist_p.F (revision 1632) +++ /LMDZ5/trunk/libf/dyn3dmem/writehist_p.F (revision 1632) @@ -0,0 +1,156 @@ +! +! $Id: writehist_p.F 1279 2009-12-10 09:02:56Z fairhead $ +! + subroutine writehist_p( histid, histvid, time, vcov, + , ucov,teta,phi,q,masse,ps,phis) + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL + USE ioipsl +#endif + USE parallel + USE misc_mod + USE infotrac + implicit none + +C +C Ecriture du fichier histoire au format IOIPSL +C +C Appels succesifs des routines: histwrite +C +C Entree: +C histid: ID du fichier histoire +C histvid:ID du fichier histoire pour les vents V (appele a disparaitre) +C time: temps de l'ecriture +C vcov: vents v covariants +C ucov: vents u covariants +C teta: temperature potentielle +C phi : geopotentiel instantane +C q : traceurs +C masse: masse +C ps :pression au sol +C phis : geopotentiel au sol +C +C +C Sortie: +C fileid: ID du fichier netcdf cree +C +C L. Fairhead, LMD, 03/99 +C +C ===================================================================== +C +C Declarations +#include "dimensions.h" +#include "paramet.h" +#include "comconst.h" +#include "comvert.h" +#include "comgeom.h" +#include "temps.h" +#include "ener.h" +#include "logic.h" +#include "description.h" +#include "serre.h" +#include "iniprint.h" + +C +C Arguments +C + + INTEGER histid, histvid + REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm) + REAL teta(ip1jmp1,llm),phi(ip1jmp1,llm) + REAL ps(ip1jmp1),masse(ip1jmp1,llm) + REAL phis(ip1jmp1) + REAL q(ip1jmp1,llm,nqtot) + integer time + +#ifdef CPP_IOIPSL +! This routine needs IOIPSL +C Variables locales +C + integer iq, ii, ll + integer ndexu(ip1jmp1*llm),ndexv(ip1jm*llm),ndex2d(ip1jmp1) + logical ok_sync + integer itau_w + integer :: ijb,ije,jjn +C +C Initialisations +C + if (adjust) return + + + ndexu = 0 + ndexv = 0 + ndex2d = 0 + ok_sync =.TRUE. + itau_w = itau_dyn + time +C +C Appels a histwrite pour l'ecriture des variables a sauvegarder +C +C Vents U +C + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(histid, 'ucov', itau_w, ucov(ijb:ije,:), + . iip1*jjn*llm, ndexu) + +C +C Vents V +C + if (pole_sud) ije=ij_end-iip1 + if (pole_sud) jjn=jj_nb-1 + + call histwrite(histvid, 'vcov', itau_w, vcov(ijb:ije,:), + . iip1*jjn*llm, ndexv) + +C +C Temperature potentielle +C + ijb=ij_begin + ije=ij_end + jjn=jj_nb + + call histwrite(histid, 'teta', itau_w, teta(ijb:ije,:), + . iip1*jjn*llm, ndexu) +C +C Geopotentiel +C + call histwrite(histid, 'phi', itau_w, phi(ijb:ije,:), + . iip1*jjn*llm, ndexu) +C +C Traceurs +C + DO iq=1,nqtot + call histwrite(histid, ttext(iq), itau_w, q(ijb:ije,:,iq), + . iip1*jjn*llm, ndexu) + enddo +C +C Masse +C + call histwrite(histid, 'masse', itau_w, masse(ijb:ije,1), + . iip1*jjn, ndex2d) +C +C Pression au sol +C + call histwrite(histid, 'ps', itau_w, ps(ijb:ije), + . iip1*jjn, ndex2d) +C +C Geopotentiel au sol +C + call histwrite(histid, 'phis', itau_w, phis(ijb:ije), + . iip1*jjn, ndex2d) +C +C Fin +C + if (ok_sync) then + call histsync(histid) + call histsync(histvid) + endif +#else + write(lunout,*)'writehist_p: Needs IOIPSL to function' +#endif +! #endif of #ifdef CPP_IOIPSL + return + end