- Timestamp:
- Apr 25, 2014, 12:20:14 PM (10 years ago)
- Location:
- LMDZ5/trunk/libf
- Files:
-
- 1 added
- 15 edited
- 6 moved
Legend:
- Unmodified
- Added
- Removed
-
LMDZ5/trunk/libf/dyn3d/gcm.F
r1930 r2021 105 105 REAL ps(ip1jmp1) ! pression au sol 106 106 REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches 107 REAL pks(ip1jmp1) ! exner au sol108 REAL pk(ip1jmp1,llm) ! exner au milieu des couches109 REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches110 107 REAL masse(ip1jmp1,llm) ! masse d'air 111 108 REAL phis(ip1jmp1) ! geopotentiel au sol … … 131 128 data call_iniphys/.true./ 132 129 133 REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)134 130 c+jld variables test conservation energie 135 131 c REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) -
LMDZ5/trunk/libf/dyn3d/guide_mod.F90
r1907 r2021 589 589 SUBROUTINE guide_interp(psi,teta) 590 590 591 use exner_hyb_m, only: exner_hyb 592 use exner_milieu_m, only: exner_milieu 591 593 IMPLICIT NONE 592 594 … … 610 612 REAL, DIMENSION (iip1,jjm,llm) :: pbary 611 613 ! Variables pour fonction Exner (P milieu couche) 612 REAL, DIMENSION (iip1,jjp1,llm) :: pk, pkf 613 REAL, DIMENSION (iip1,jjp1,llm) :: alpha, beta 614 REAL, DIMENSION (iip1,jjp1,llm) :: pk 614 615 REAL, DIMENSION (iip1,jjp1) :: pks 615 616 REAL :: prefkap,unskap … … 676 677 CALL pression( ip1jmp1, ap, bp, psi, p ) 677 678 if (pressure_exner) then 678 CALL exner_hyb(ip1jmp1,psi,p, alpha,beta,pks,pk,pkf)679 CALL exner_hyb(ip1jmp1,psi,p,pks,pk) 679 680 else 680 CALL exner_milieu(ip1jmp1,psi,p, beta,pks,pk,pkf)681 CALL exner_milieu(ip1jmp1,psi,p,pks,pk) 681 682 endif 682 683 ! .... Calcul de pls , pression au milieu des couches ,en Pascals -
LMDZ5/trunk/libf/dyn3d/iniacademic.F90
r1907 r2021 14 14 #endif 15 15 USE Write_Field 16 use exner_hyb_m, only: exner_hyb 17 use exner_milieu_m, only: exner_milieu 16 18 17 19 ! Author: Frederic Hourdin original: 15/01/93 … … 54 56 REAL pks(ip1jmp1) ! exner au sol 55 57 REAL pk(ip1jmp1,llm) ! exner au milieu des couches 56 REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches57 58 REAL phi(ip1jmp1,llm) ! geopotentiel 58 59 REAL ddsin,zsig,tetapv,w_pv ! variables auxiliaires … … 70 71 integer idum 71 72 72 REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr73 REAL zdtvr 73 74 74 75 character(len=*),parameter :: modname="iniacademic" … … 223 224 CALL pression ( ip1jmp1, ap, bp, ps, p ) 224 225 if (pressure_exner) then 225 CALL exner_hyb( ip1jmp1, ps, p, alpha,beta, pks, pk, pkf)226 else 227 call exner_milieu(ip1jmp1,ps,p, beta,pks,pk,pkf)226 CALL exner_hyb( ip1jmp1, ps, p, pks, pk) 227 else 228 call exner_milieu(ip1jmp1,ps,p,pks,pk) 228 229 endif 229 230 CALL massdair(p,masse) -
LMDZ5/trunk/libf/dyn3d/leapfrog.F
r1987 r2021 19 19 & iecri, ip_ebil_dyn, ok_dynzon, ok_dyn_ins, 20 20 & periodav, ok_dyn_ave, output_grads_dyn 21 use exner_hyb_m, only: exner_hyb 22 use exner_milieu_m, only: exner_milieu 23 21 24 IMPLICIT NONE 22 25 … … 158 161 character*10 string10 159 162 160 REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)161 163 REAL :: flxw(ip1jmp1,llm) ! flux de masse verticale 162 164 … … 217 219 CALL pression ( ip1jmp1, ap, bp, ps, p ) 218 220 if (pressure_exner) then 219 CALL exner_hyb( ip1jmp1, ps, p, alpha,beta,pks, pk, pkf )221 CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf ) 220 222 else 221 CALL exner_milieu( ip1jmp1, ps, p, beta,pks, pk, pkf )223 CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf ) 222 224 endif 223 225 … … 373 375 CALL pression ( ip1jmp1, ap, bp, ps, p ) 374 376 if (pressure_exner) then 375 CALL exner_hyb( ip1jmp1, ps, p, alpha,beta,pks, pk, pkf )377 CALL exner_hyb( ip1jmp1, ps, p,pks, pk, pkf ) 376 378 else 377 CALL exner_milieu( ip1jmp1, ps, p, beta,pks, pk, pkf )379 CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf ) 378 380 endif 379 381 … … 448 450 CALL massdair(p,masse) 449 451 if (pressure_exner) then 450 CALL exner_hyb(ip1jmp1,ps,p, alpha,beta,pks,pk,pkf)452 CALL exner_hyb(ip1jmp1,ps,p,pks,pk,pkf) 451 453 else 452 CALL exner_milieu(ip1jmp1,ps,p, beta,pks,pk,pkf)454 CALL exner_milieu(ip1jmp1,ps,p,pks,pk,pkf) 453 455 endif 454 456 … … 506 508 CALL pression ( ip1jmp1, ap, bp, ps, p ) 507 509 if (pressure_exner) then 508 CALL exner_hyb( ip1jmp1, ps, p, alpha,beta,pks, pk, pkf )510 CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf ) 509 511 else 510 CALL exner_milieu( ip1jmp1, ps, p, beta,pks, pk, pkf )512 CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf ) 511 513 endif 512 514 CALL massdair(p,masse) -
LMDZ5/trunk/libf/dyn3d_common/exner_hyb_m.F90
r1992 r2021 1 ! 2 ! $Id $ 3 ! 4 SUBROUTINE exner_hyb ( ngrid, ps, p,alpha,beta, pks, pk, pkf ) 5 c 6 c Auteurs : P.Le Van , Fr. Hourdin . 7 c .......... 8 c 9 c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 10 c .... alpha,beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... 11 c 12 c ************************************************************************ 13 c Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des 14 c couches . Pk(l) sera calcule aux milieux des couches l ,entre les 15 c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 16 c ************************************************************************ 17 c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 18 c la pression et la fonction d'Exner au sol . 19 c 20 c -------- z 21 c A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et 22 c ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) 23 c ( voir note de Fr.Hourdin ) , 24 c 25 c on determine successivement , du haut vers le bas des couches, les 26 c coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 27 c puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, 28 c pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . 29 c 30 c 31 IMPLICIT NONE 32 c 33 #include "dimensions.h" 34 #include "paramet.h" 35 #include "comconst.h" 36 #include "comgeom.h" 37 #include "comvert.h" 38 #include "serre.h" 1 module exner_hyb_m 39 2 40 INTEGER ngrid 41 REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) 42 REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm) 3 IMPLICIT NONE 43 4 44 c .... variables locales ...5 contains 45 6 46 INTEGER l, ij 47 REAL unpl2k,dellta 7 SUBROUTINE exner_hyb ( ngrid, ps, p, pks, pk, pkf ) 48 8 49 REAL ppn(iim),pps(iim) 50 REAL xpn, xps 51 REAL SSUM 52 c 53 logical,save :: firstcall=.true. 54 character(len=*),parameter :: modname="exner_hyb" 55 56 ! Sanity check 57 if (firstcall) then 58 ! sanity checks for Shallow Water case (1 vertical layer) 59 if (llm.eq.1) then 9 ! Auteurs : P.Le Van , Fr. Hourdin . 10 ! .......... 11 ! 12 ! .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 13 ! .... pks,pk,pkf sont des argum.de sortie au sous-prog ... 14 ! 15 ! ************************************************************************ 16 ! Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 17 ! couches . Pk(l) sera calcule aux milieux des couches l ,entre les 18 ! pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 19 ! ************************************************************************ 20 ! .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 21 ! la pression et la fonction d'Exner au sol . 22 ! 23 ! -------- z 24 ! A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et 25 ! ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) 26 ! ( voir note de Fr.Hourdin ) , 27 ! 28 ! on determine successivement , du haut vers le bas des couches, les 29 ! coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 30 ! puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, 31 ! pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . 32 ! 33 ! 34 ! 35 include "dimensions.h" 36 include "paramet.h" 37 include "comconst.h" 38 include "comgeom.h" 39 include "comvert.h" 40 include "serre.h" 41 42 INTEGER ngrid 43 REAL p(ngrid,llmp1),pk(ngrid,llm) 44 real, optional:: pkf(ngrid,llm) 45 REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm) 46 47 ! .... variables locales ... 48 49 INTEGER l, ij 50 REAL unpl2k,dellta 51 52 logical,save :: firstcall=.true. 53 character(len=*),parameter :: modname="exner_hyb" 54 55 ! Sanity check 56 if (firstcall) then 57 ! sanity checks for Shallow Water case (1 vertical layer) 58 if (llm.eq.1) then 60 59 if (kappa.ne.1) then 61 call abort_gcm(modname,62 &"kappa!=1 , but running in Shallow Water mode!!",42)60 call abort_gcm(modname, & 61 "kappa!=1 , but running in Shallow Water mode!!",42) 63 62 endif 64 63 if (cpp.ne.r) then 65 call abort_gcm(modname,66 &"cpp!=r , but running in Shallow Water mode!!",42)64 call abort_gcm(modname, & 65 "cpp!=r , but running in Shallow Water mode!!",42) 67 66 endif 68 67 endif ! of if (llm.eq.1) 69 68 70 71 69 firstcall=.false. 70 endif ! of if (firstcall) 72 71 73 if (llm.eq.1) then 74 75 ! Compute pks(:),pk(:),pkf(:) 76 77 DO ij = 1, ngrid 78 pks(ij) = (cpp/preff) * ps(ij) 72 ! Specific behaviour for Shallow Water (1 vertical layer) case: 73 if (llm.eq.1) then 74 75 ! Compute pks(:),pk(:),pkf(:) 76 77 DO ij = 1, ngrid 78 pks(ij) = (cpp/preff) * ps(ij) 79 79 pk(ij,1) = .5*pks(ij) 80 ENDDO 81 82 CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) 83 CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 84 85 ! our work is done, exit routine 86 return 80 ENDDO 87 81 88 endif ! of if (llm.eq.1) 82 if (present(pkf)) then 83 pkf = pk 84 CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 85 end if 89 86 90 !!!! General case: 91 92 unpl2k = 1.+ 2.* kappa 93 c 94 DO ij = 1, ngrid 95 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 96 ENDDO 87 ! our work is done, exit routine 88 return 89 endif ! of if (llm.eq.1) 97 90 98 DO ij = 1, iim 99 ppn(ij) = aire( ij ) * pks( ij ) 100 pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) 101 ENDDO 102 xpn = SSUM(iim,ppn,1) /apoln 103 xps = SSUM(iim,pps,1) /apols 91 ! General case: 104 92 105 DO ij = 1, iip1 106 pks( ij ) = xpn 107 pks( ij+ip1jm ) = xps 108 ENDDO 109 c 110 c 111 c .... Calcul des coeff. alpha et beta pour la couche l = llm .. 112 c 113 DO ij = 1, ngrid 93 unpl2k = 1.+ 2.* kappa 94 95 ! ------------- 96 ! Calcul de pks 97 ! ------------- 98 99 DO ij = 1, ngrid 100 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 101 ENDDO 102 103 ! .... Calcul des coeff. alpha et beta pour la couche l = llm .. 104 ! 105 DO ij = 1, ngrid 114 106 alpha(ij,llm) = 0. 115 107 beta (ij,llm) = 1./ unpl2k 116 ENDDO 117 c 118 c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... 119 c 120 DO l = llm -1 , 2 , -1 121 c 122 DO ij = 1, ngrid 123 dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) 124 alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) 125 beta (ij,l) = p(ij,l ) / dellta 126 ENDDO 127 c 128 ENDDO 129 c 130 c *********************************************************************** 131 c ..... Calcul de pk pour la couche 1 , pres du sol .... 132 c 133 DO ij = 1, ngrid 134 pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / 135 * ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) 136 ENDDO 137 c 138 c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ 139 c 140 DO l = 2, llm 141 DO ij = 1, ngrid 142 pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) 143 ENDDO 144 ENDDO 145 c 146 c 147 CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) 148 CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 149 108 ENDDO 109 ! 110 ! ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... 111 ! 112 DO l = llm -1 , 2 , -1 113 ! 114 DO ij = 1, ngrid 115 dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) 116 alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) 117 beta (ij,l) = p(ij,l ) / dellta 118 ENDDO 119 ENDDO 150 120 151 RETURN 152 END 121 ! *********************************************************************** 122 ! ..... Calcul de pk pour la couche 1 , pres du sol .... 123 ! 124 DO ij = 1, ngrid 125 pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / & 126 ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) 127 ENDDO 128 ! 129 ! ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ 130 ! 131 DO l = 2, llm 132 DO ij = 1, ngrid 133 pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) 134 ENDDO 135 ENDDO 136 137 if (present(pkf)) then 138 ! calcul de pkf 139 pkf = pk 140 CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 141 end if 142 143 END SUBROUTINE exner_hyb 144 145 end module exner_hyb_m -
LMDZ5/trunk/libf/dyn3d_common/exner_milieu_m.F90
r1992 r2021 1 ! 2 ! $Id $ 3 ! 4 SUBROUTINE exner_milieu ( ngrid, ps, p,beta, pks, pk, pkf ) 5 c 6 c Auteurs : F. Forget , Y. Wanherdrick 7 c P.Le Van , Fr. Hourdin . 8 c .......... 9 c 10 c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 11 c .... beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... 12 c 13 c ************************************************************************ 14 c Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 15 c couches . Pk(l) sera calcule aux milieux des couches l ,entre les 16 c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 17 c ************************************************************************ 18 c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 19 c la pression et la fonction d'Exner au sol . 20 c 21 c WARNING : CECI est une version speciale de exner_hyb originale 22 c Utilise dans la version martienne pour pouvoir 23 c tourner avec des coordonnees verticales complexe 24 c => Il ne verifie PAS la condition la proportionalite en 25 c energie totale/ interne / potentielle (F.Forget 2001) 26 c ( voir note de Fr.Hourdin ) , 27 c 28 IMPLICIT NONE 29 c 30 #include "dimensions.h" 31 #include "paramet.h" 32 #include "comconst.h" 33 #include "comgeom.h" 34 #include "comvert.h" 35 #include "serre.h" 1 module exner_milieu_m 36 2 37 INTEGER ngrid 38 REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) 39 REAL ps(ngrid),pks(ngrid), beta(ngrid,llm) 3 IMPLICIT NONE 40 4 41 c .... variables locales ...5 contains 42 6 43 INTEGER l, ij 44 REAL dum1 7 SUBROUTINE exner_milieu ( ngrid, ps, p, pks, pk, pkf ) 8 ! 9 ! Auteurs : F. Forget , Y. Wanherdrick 10 ! P.Le Van , Fr. Hourdin . 11 ! .......... 12 ! 13 ! .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 14 ! .... pks,pk,pkf sont des argum.de sortie au sous-prog ... 15 ! 16 ! ************************************************************************ 17 ! Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 18 ! couches . Pk(l) sera calcule aux milieux des couches l ,entre les 19 ! pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 20 ! ************************************************************************ 21 ! .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 22 ! la pression et la fonction d'Exner au sol . 23 ! 24 ! WARNING : CECI est une version speciale de exner_hyb originale 25 ! Utilise dans la version martienne pour pouvoir 26 ! tourner avec des coordonnees verticales complexe 27 ! => Il ne verifie PAS la condition la proportionalite en 28 ! energie totale/ interne / potentielle (F.Forget 2001) 29 ! ( voir note de Fr.Hourdin ) , 30 ! 31 ! 32 include "dimensions.h" 33 include "paramet.h" 34 include "comconst.h" 35 include "comgeom.h" 36 include "comvert.h" 37 include "serre.h" 45 38 46 REAL ppn(iim),pps(iim) 47 REAL xpn, xps 48 REAL SSUM 49 EXTERNAL SSUM 50 logical,save :: firstcall=.true. 51 character(len=*),parameter :: modname="exner_milieu" 39 INTEGER ngrid 40 REAL p(ngrid,llmp1),pk(ngrid,llm) 41 real, optional:: pkf(ngrid,llm) 42 REAL ps(ngrid),pks(ngrid) 52 43 53 ! Sanity check 54 if (firstcall) then 55 ! sanity checks for Shallow Water case (1 vertical layer) 56 if (llm.eq.1) then 44 ! .... variables locales ... 45 46 INTEGER l, ij 47 REAL dum1 48 49 logical,save :: firstcall=.true. 50 character(len=*),parameter :: modname="exner_milieu" 51 52 ! Sanity check 53 if (firstcall) then 54 ! sanity checks for Shallow Water case (1 vertical layer) 55 if (llm.eq.1) then 57 56 if (kappa.ne.1) then 58 call abort_gcm(modname,59 &"kappa!=1 , but running in Shallow Water mode!!",42)57 call abort_gcm(modname, & 58 "kappa!=1 , but running in Shallow Water mode!!",42) 60 59 endif 61 60 if (cpp.ne.r) then 62 call abort_gcm(modname,63 &"cpp!=r , but running in Shallow Water mode!!",42)61 call abort_gcm(modname, & 62 "cpp!=r , but running in Shallow Water mode!!",42) 64 63 endif 65 64 endif ! of if (llm.eq.1) 66 65 67 68 66 firstcall=.false. 67 endif ! of if (firstcall) 69 68 70 !!!! Specific behaviour for Shallow Water (1 vertical layer) case:71 72 73 74 75 76 pks(ij) = (cpp/preff) * ps(ij) 69 ! Specific behaviour for Shallow Water (1 vertical layer) case: 70 if (llm.eq.1) then 71 72 ! Compute pks(:),pk(:),pkf(:) 73 74 DO ij = 1, ngrid 75 pks(ij) = (cpp/preff) * ps(ij) 77 76 pk(ij,1) = .5*pks(ij) 78 ENDDO 79 80 CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) 81 CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 82 83 ! our work is done, exit routine 84 return 77 ENDDO 85 78 86 endif ! of if (llm.eq.1) 79 if (present(pkf)) then 80 pkf = pk 81 CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 82 end if 87 83 88 !!!! General case: 84 ! our work is done, exit routine 85 return 86 endif ! of if (llm.eq.1) 89 87 90 c ------------- 91 c Calcul de pks 92 c ------------- 93 94 DO ij = 1, ngrid 95 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 96 ENDDO 88 ! General case: 97 89 98 DO ij = 1, iim 99 ppn(ij) = aire( ij ) * pks( ij ) 100 pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) 101 ENDDO 102 xpn = SSUM(iim,ppn,1) /apoln 103 xps = SSUM(iim,pps,1) /apols 90 ! ------------- 91 ! Calcul de pks 92 ! ------------- 104 93 105 DO ij = 1, iip1 106 pks( ij ) = xpn 107 pks( ij+ip1jm ) = xps 108 ENDDO 109 c 110 c 111 c .... Calcul de pk pour la couche l 112 c -------------------------------------------- 113 c 114 dum1 = cpp * (2*preff)**(-kappa) 115 DO l = 1, llm-1 116 DO ij = 1, ngrid 117 pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa 118 ENDDO 119 ENDDO 94 DO ij = 1, ngrid 95 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 96 ENDDO 120 97 121 c .... Calcul de pk pour la couche l = llm .. 122 c (on met la meme distance (en log pression) entre Pk(llm) 123 c et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) 98 ! .... Calcul de pk pour la couche l 99 ! -------------------------------------------- 100 ! 101 dum1 = cpp * (2*preff)**(-kappa) 102 DO l = 1, llm-1 103 DO ij = 1, ngrid 104 pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa 105 ENDDO 106 ENDDO 124 107 125 DO ij = 1, ngrid126 pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2)127 ENDDO108 ! .... Calcul de pk pour la couche l = llm .. 109 ! (on met la meme distance (en log pression) entre Pk(llm) 110 ! et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) 128 111 112 DO ij = 1, ngrid 113 pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2) 114 ENDDO 129 115 130 c calcul de pkf 131 c ------------- 132 CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) 133 CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 134 135 c EST-CE UTILE ?? : calcul de beta 136 c -------------------------------- 137 DO l = 2, llm 138 DO ij = 1, ngrid 139 beta(ij,l) = pk(ij,l) / pk(ij,l-1) 140 ENDDO 141 ENDDO 116 if (present(pkf)) then 117 ! calcul de pkf 118 pkf = pk 119 CALL filtreg ( pkf, jmp1, llm, 2, 1, .TRUE., 1 ) 120 end if 142 121 143 RETURN 144 END 122 END SUBROUTINE exner_milieu 123 124 end module exner_milieu_m -
LMDZ5/trunk/libf/dyn3dmem/call_calfis_mod.F90
r1987 r2021 12 12 13 13 REAL,POINTER,SAVE :: p(:,:) 14 REAL,POINTER,SAVE :: alpha(:,:)15 REAL,POINTER,SAVE :: beta(:,:)16 14 REAL,POINTER,SAVE :: pks(:) 17 15 REAL,POINTER,SAVE :: pk(:,:) … … 53 51 CALL allocate_u(flxw,llm,d) 54 52 CALL allocate_u(p,llmp1,d) 55 CALL allocate_u(alpha,llm,d)56 CALL allocate_u(beta,llm,d)57 53 CALL allocate_u(pks,d) 58 54 CALL allocate_u(pk,llm,d) … … 75 71 phis_dyn,q_dyn,flxw_dyn) 76 72 USE dimensions_mod 73 use exner_hyb_loc_m, only: exner_hyb_loc 74 use exner_milieu_loc_m, only: exner_milieu_loc 77 75 USE parallel_lmdz 78 76 USE times … … 201 199 202 200 !$OMP BARRIER 203 CALL exner_hyb_loc( ip1jmp1, ps, p, alpha,beta,pks, pk, pkf )201 CALL exner_hyb_loc( ip1jmp1, ps, p, pks, pk, pkf ) 204 202 !$OMP BARRIER 205 203 CALL geopot_loc ( ip1jmp1, teta , pk , pks, phis , phi ) … … 343 341 !$OMP BARRIER 344 342 if (pressure_exner) then 345 CALL exner_hyb_loc(ijnb_u,ps,p, alpha,beta,pks,pk,pkf)343 CALL exner_hyb_loc(ijnb_u,ps,p,pks,pk,pkf) 346 344 else 347 CALL exner_milieu_loc(ijnb_u,ps,p, beta,pks,pk,pkf)345 CALL exner_milieu_loc(ijnb_u,ps,p,pks,pk,pkf) 348 346 endif 349 347 !$OMP BARRIER -
LMDZ5/trunk/libf/dyn3dmem/exner_hyb_loc_m.F90
r1992 r2021 1 c 2 c $Id$ 3 c 4 SUBROUTINE exner_hyb_loc(ngrid, ps, p,alpha,beta, pks,pk,pkf) 5 c 6 c Auteurs : P.Le Van , Fr. Hourdin . 7 c .......... 8 c 9 c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 10 c .... alpha,beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... 11 c 12 c ************************************************************************ 13 c Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des 14 c couches . Pk(l) sera calcule aux milieux des couches l ,entre les 15 c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 16 c ************************************************************************ 17 c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 18 c la pression et la fonction d'Exner au sol . 19 c 20 c -------- z 21 c A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et 22 c ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) 23 c ( voir note de Fr.Hourdin ) , 24 c 25 c on determine successivement , du haut vers le bas des couches, les 26 c coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 27 c puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, 28 c pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . 29 c 30 c 31 USE parallel_lmdz 32 USE mod_filtreg_p 33 USE write_field_loc 34 IMPLICIT NONE 35 c 36 #include "dimensions.h" 37 #include "paramet.h" 38 #include "comconst.h" 39 #include "comgeom.h" 40 #include "comvert.h" 41 #include "serre.h" 1 module exner_hyb_loc_m 42 2 43 INTEGER ngrid 44 REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm) 45 REAL pkf(ijb_u:ije_u,llm) 46 REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u) 47 REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm) 3 IMPLICIT NONE 48 4 49 c .... variables locales ...5 contains 50 6 51 INTEGER l, ij 52 REAL unpl2k,dellta 7 SUBROUTINE exner_hyb_loc(ngrid, ps, p, pks,pk,pkf) 53 8 54 REAL ppn(iim),pps(iim) 55 REAL xpn, xps 56 REAL SSUM 57 EXTERNAL SSUM 58 INTEGER ije,ijb,jje,jjb 59 logical,save :: firstcall=.true. 60 !$OMP THREADPRIVATE(firstcall) 61 character(len=*),parameter :: modname="exner_hyb_loc" 62 c 63 c$OMP BARRIER 9 ! Auteurs : P.Le Van , Fr. Hourdin . 10 ! .......... 11 ! 12 ! .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 13 ! .... pks,pk,pkf sont des argum.de sortie au sous-prog ... 14 ! 15 ! ************************************************************************ 16 ! Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 17 ! couches . Pk(l) sera calcule aux milieux des couches l ,entre les 18 ! pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 19 ! ************************************************************************ 20 ! .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 21 ! la pression et la fonction d'Exner au sol . 22 ! 23 ! -------- z 24 ! A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et 25 ! ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) 26 ! ( voir note de Fr.Hourdin ) , 27 ! 28 ! on determine successivement , du haut vers le bas des couches, les 29 ! coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 30 ! puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, 31 ! pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . 32 ! 33 ! 34 USE parallel_lmdz 35 USE mod_filtreg_p 36 USE write_field_loc 37 ! 38 include "dimensions.h" 39 include "paramet.h" 40 include "comconst.h" 41 include "comgeom.h" 42 include "comvert.h" 43 include "serre.h" 64 44 65 ! Sanity check 66 if (firstcall) then 67 ! sanity checks for Shallow Water case (1 vertical layer) 68 if (llm.eq.1) then 45 INTEGER ngrid 46 REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm) 47 REAL, optional:: pkf(ijb_u:ije_u,llm) 48 REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u) 49 REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm) 50 51 ! .... variables locales ... 52 53 INTEGER l, ij 54 REAL unpl2k,dellta 55 56 INTEGER ije,ijb,jje,jjb 57 logical,save :: firstcall=.true. 58 !$OMP THREADPRIVATE(firstcall) 59 character(len=*),parameter :: modname="exner_hyb_loc" 60 ! 61 !$OMP BARRIER 62 63 ! Sanity check 64 if (firstcall) then 65 ! sanity checks for Shallow Water case (1 vertical layer) 66 if (llm.eq.1) then 69 67 if (kappa.ne.1) then 70 call abort_gcm(modname,71 &"kappa!=1 , but running in Shallow Water mode!!",42)68 call abort_gcm(modname, & 69 "kappa!=1 , but running in Shallow Water mode!!",42) 72 70 endif 73 71 if (cpp.ne.r) then 74 call abort_gcm(modname,75 &"cpp!=r , but running in Shallow Water mode!!",42)72 call abort_gcm(modname, & 73 "cpp!=r , but running in Shallow Water mode!!",42) 76 74 endif 77 75 endif ! of if (llm.eq.1) 78 76 79 80 77 firstcall=.false. 78 endif ! of if (firstcall) 81 79 82 c$OMP BARRIER80 !$OMP BARRIER 83 81 84 ! Specific behaviour for Shallow Water (1 vertical layer) case 85 86 87 88 89 90 !$OMP DO SCHEDULE(STATIC)91 92 pks(ij) =(cpp/preff)*ps(ij)82 ! Specific behaviour for Shallow Water (1 vertical layer) case: 83 if (llm.eq.1) then 84 85 ! Compute pks(:),pk(:),pkf(:) 86 ijb=ij_begin 87 ije=ij_end 88 !$OMP DO SCHEDULE(STATIC) 89 DO ij=ijb, ije 90 pks(ij) = (cpp/preff) * ps(ij) 93 91 pk(ij,1) = .5*pks(ij) 94 pkf(ij,1)=pk(ij,1)95 96 !$OMP ENDDO92 if (present(pkf)) pkf(ij,1)=pk(ij,1) 93 ENDDO 94 !$OMP ENDDO 97 95 98 !$OMP MASTER 99 if (pole_nord) then 100 DO ij = 1, iim 101 ppn(ij) = aire( ij ) * pks( ij ) 102 ENDDO 103 xpn = SSUM(iim,ppn,1) /apoln 104 105 DO ij = 1, iip1 106 pks( ij ) = xpn 107 pk(ij,1) = .5*pks(ij) 108 pkf(ij,1)=pk(ij,1) 109 ENDDO 110 endif 111 112 if (pole_sud) then 113 DO ij = 1, iim 114 pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) 115 ENDDO 116 xps = SSUM(iim,pps,1) /apols 117 118 DO ij = 1, iip1 119 pks( ij+ip1jm ) = xps 120 pk(ij+ip1jm,1)=.5*pks(ij+ip1jm) 121 pkf(ij+ip1jm,1)=pk(ij+ip1jm,1) 122 ENDDO 123 endif 124 !$OMP END MASTER 125 !$OMP BARRIER 126 jjb=jj_begin 127 jje=jj_end 128 CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, 129 & 2, 1, .TRUE., 1 ) 96 !$OMP BARRIER 97 if (present(pkf)) then 98 jjb=jj_begin 99 jje=jj_end 100 CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, & 101 2, 1, .TRUE., 1 ) 102 end if 130 103 131 132 133 104 ! our work is done, exit routine 105 return 106 endif ! of if (llm.eq.1) 134 107 108 ! General case: 135 109 136 unpl2k = 1.+ 2.* kappa 137 c 138 ijb=ij_begin 139 ije=ij_end 110 unpl2k = 1.+ 2.* kappa 140 111 141 c$OMP DO SCHEDULE(STATIC) 142 DO ij = ijb, ije 143 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 144 ENDDO 145 c$OMP ENDDO 146 c Synchro OPENMP ici 112 ! ------------- 113 ! Calcul de pks 114 ! ------------- 147 115 148 c$OMP MASTER 149 if (pole_nord) then 150 DO ij = 1, iim 151 ppn(ij) = aire( ij ) * pks( ij ) 152 ENDDO 153 xpn = SSUM(iim,ppn,1) /apoln 154 155 DO ij = 1, iip1 156 pks( ij ) = xpn 157 ENDDO 158 endif 159 160 if (pole_sud) then 161 DO ij = 1, iim 162 pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) 163 ENDDO 164 xps = SSUM(iim,pps,1) /apols 165 166 DO ij = 1, iip1 167 pks( ij+ip1jm ) = xps 168 ENDDO 169 endif 170 c$OMP END MASTER 171 c$OMP BARRIER 172 c 173 c 174 c .... Calcul des coeff. alpha et beta pour la couche l = llm .. 175 c 176 c$OMP DO SCHEDULE(STATIC) 177 DO ij = ijb,ije 116 ijb=ij_begin 117 ije=ij_end 118 119 !$OMP DO SCHEDULE(STATIC) 120 DO ij = ijb, ije 121 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 122 ENDDO 123 !$OMP ENDDO 124 ! Synchro OPENMP ici 125 126 !$OMP BARRIER 127 ! 128 ! 129 ! .... Calcul des coeff. alpha et beta pour la couche l = llm .. 130 ! 131 !$OMP DO SCHEDULE(STATIC) 132 DO ij = ijb,ije 178 133 alpha(ij,llm) = 0. 179 134 beta (ij,llm) = 1./ unpl2k 180 ENDDO 181 c$OMP ENDDO NOWAIT 182 c 183 c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... 184 c 185 DO l = llm -1 , 2 , -1 186 c 187 c$OMP DO SCHEDULE(STATIC) 188 DO ij = ijb, ije 189 dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) 190 alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) 191 beta (ij,l) = p(ij,l ) / dellta 192 ENDDO 193 c$OMP ENDDO NOWAIT 194 c 195 ENDDO 135 ENDDO 136 !$OMP ENDDO NOWAIT 137 ! 138 ! ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... 139 ! 140 DO l = llm -1 , 2 , -1 141 ! 142 !$OMP DO SCHEDULE(STATIC) 143 DO ij = ijb, ije 144 dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) 145 alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) 146 beta (ij,l) = p(ij,l ) / dellta 147 ENDDO 148 !$OMP ENDDO NOWAIT 149 ENDDO 196 150 197 c 198 c *********************************************************************** 199 c ..... Calcul de pk pour la couche 1 , pres du sol .... 200 c 201 c$OMP DO SCHEDULE(STATIC) 202 DO ij = ijb, ije 203 pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / 204 * ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) 205 ENDDO 206 c$OMP ENDDO NOWAIT 207 c 208 c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ 209 c 210 DO l = 2, llm 211 c$OMP DO SCHEDULE(STATIC) 212 DO ij = ijb, ije 213 pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) 214 ENDDO 215 c$OMP ENDDO NOWAIT 216 ENDDO 217 c 218 c 219 c CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) 220 DO l = 1, llm 221 c$OMP DO SCHEDULE(STATIC) 222 DO ij = ijb, ije 223 pkf(ij,l)=pk(ij,l) 224 ENDDO 225 c$OMP ENDDO NOWAIT 226 ENDDO 151 ! *********************************************************************** 152 ! ..... Calcul de pk pour la couche 1 , pres du sol .... 153 ! 154 !$OMP DO SCHEDULE(STATIC) 155 DO ij = ijb, ije 156 pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / & 157 ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) 158 ENDDO 159 !$OMP ENDDO NOWAIT 160 ! 161 ! ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ 162 ! 163 DO l = 2, llm 164 !$OMP DO SCHEDULE(STATIC) 165 DO ij = ijb, ije 166 pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) 167 ENDDO 168 !$OMP ENDDO NOWAIT 169 ENDDO 227 170 228 c$OMP BARRIER 229 230 jjb=jj_begin 231 jje=jj_end 171 if (present(pkf)) then 172 ! calcul de pkf 173 174 DO l = 1, llm 175 !$OMP DO SCHEDULE(STATIC) 176 DO ij = ijb, ije 177 pkf(ij,l)=pk(ij,l) 178 ENDDO 179 !$OMP ENDDO NOWAIT 180 ENDDO 181 182 !$OMP BARRIER 183 184 jjb=jj_begin 185 jje=jj_end 232 186 #ifdef DEBUG_IO 233 call WriteField_u('pkf',pkf)187 call WriteField_u('pkf',pkf) 234 188 #endif 235 CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm,236 &2, 1, .TRUE., 1 )189 CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, & 190 2, 1, .TRUE., 1 ) 237 191 #ifdef DEBUG_IO 238 call WriteField_u('pkf',pkf) 239 #endif 192 call WriteField_u('pkf',pkf) 193 #endif 194 end if 240 195 241 RETURN 242 END 196 END SUBROUTINE exner_hyb_loc 197 198 end module exner_hyb_loc_m -
LMDZ5/trunk/libf/dyn3dmem/exner_milieu_loc_m.F90
r1992 r2021 1 ! 2 ! $Id$ 3 ! 4 SUBROUTINE exner_milieu_loc ( ngrid, ps, p,beta, pks, pk, pkf ) 5 c 6 c Auteurs : F. Forget , Y. Wanherdrick 7 c P.Le Van , Fr. Hourdin . 8 c .......... 9 c 10 c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 11 c .... beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... 12 c 13 c ************************************************************************ 14 c Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 15 c couches . Pk(l) sera calcule aux milieux des couches l ,entre les 16 c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 17 c ************************************************************************ 18 c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 19 c la pression et la fonction d'Exner au sol . 20 c 21 c WARNING : CECI est une version speciale de exner_hyb originale 22 c Utilise dans la version martienne pour pouvoir 23 c tourner avec des coordonnees verticales complexe 24 c => Il ne verifie PAS la condition la proportionalite en 25 c energie totale/ interne / potentielle (F.Forget 2001) 26 c ( voir note de Fr.Hourdin ) , 27 c 28 USE parallel_lmdz 29 USE mod_filtreg_p 30 IMPLICIT NONE 31 c 32 #include "dimensions.h" 33 #include "paramet.h" 34 #include "comconst.h" 35 #include "comgeom.h" 36 #include "comvert.h" 37 #include "serre.h" 1 module exner_milieu_loc_m 38 2 39 INTEGER ngrid 40 REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm) 41 REAL pkf(ijb_u:ije_u,llm) 42 REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u) 43 REAL alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm) 3 IMPLICIT NONE 44 4 45 c .... variables locales ...5 contains 46 6 47 INTEGER l, ij 48 REAL dum1 7 SUBROUTINE exner_milieu_loc ( ngrid, ps, p, pks, pk, pkf ) 8 ! 9 ! Auteurs : F. Forget , Y. Wanherdrick 10 ! P.Le Van , Fr. Hourdin . 11 ! .......... 12 ! 13 ! .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 14 ! .... pks,pk,pkf sont des argum.de sortie au sous-prog ... 15 ! 16 ! ************************************************************************ 17 ! Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 18 ! couches . Pk(l) sera calcule aux milieux des couches l ,entre les 19 ! pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 20 ! ************************************************************************ 21 ! .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 22 ! la pression et la fonction d'Exner au sol . 23 ! 24 ! WARNING : CECI est une version speciale de exner_hyb originale 25 ! Utilise dans la version martienne pour pouvoir 26 ! tourner avec des coordonnees verticales complexe 27 ! => Il ne verifie PAS la condition la proportionalite en 28 ! energie totale/ interne / potentielle (F.Forget 2001) 29 ! ( voir note de Fr.Hourdin ) , 30 ! 31 USE parallel_lmdz 32 USE mod_filtreg_p 33 ! 34 include "dimensions.h" 35 include "paramet.h" 36 include "comconst.h" 37 include "comgeom.h" 38 include "comvert.h" 39 include "serre.h" 49 40 50 REAL ppn(iim),pps(iim) 51 REAL xpn, xps 52 REAL SSUM 53 EXTERNAL SSUM 54 INTEGER ije,ijb,jje,jjb 55 logical,save :: firstcall=.true. 56 !$OMP THREADPRIVATE(firstcall) 57 character(len=*),parameter :: modname="exner_milieu_loc" 41 INTEGER ngrid 42 REAL p(ijb_u:ije_u,llmp1),pk(ijb_u:ije_u,llm) 43 REAL, optional:: pkf(ijb_u:ije_u,llm) 44 REAL ps(ijb_u:ije_u),pks(ijb_u:ije_u) 58 45 59 ! Sanity check 60 if (firstcall) then 61 62 ! sanity checks for Shallow Water case (1 vertical layer) 63 if (llm.eq.1) then 46 ! .... variables locales ... 47 48 INTEGER l, ij 49 REAL dum1 50 51 INTEGER ije,ijb,jje,jjb 52 logical,save :: firstcall=.true. 53 !$OMP THREADPRIVATE(firstcall) 54 character(len=*),parameter :: modname="exner_milieu_loc" 55 56 ! Sanity check 57 if (firstcall) then 58 ! sanity checks for Shallow Water case (1 vertical layer) 59 if (llm.eq.1) then 64 60 if (kappa.ne.1) then 65 call abort_gcm(modname,66 &"kappa!=1 , but running in Shallow Water mode!!",42)61 call abort_gcm(modname, & 62 "kappa!=1 , but running in Shallow Water mode!!",42) 67 63 endif 68 64 if (cpp.ne.r) then 69 call abort_gcm(modname,70 &"cpp!=r , but running in Shallow Water mode!!",42)65 call abort_gcm(modname, & 66 "cpp!=r , but running in Shallow Water mode!!",42) 71 67 endif 72 68 endif ! of if (llm.eq.1) 73 69 74 firstcall=.false. 75 endif ! of if (firstcall) 76 77 c$OMP BARRIER 70 firstcall=.false. 71 endif ! of if (firstcall) 78 72 79 ! Specific behaviour for Shallow Water (1 vertical layer) case 80 if (llm.eq.1) then 81 82 ! Compute pks(:),pk(:),pkf(:) 83 ijb=ij_begin 84 ije=ij_end 85 !$OMP DO SCHEDULE(STATIC) 86 DO ij=ijb, ije 87 pks(ij)=(cpp/preff)*ps(ij) 73 !$OMP BARRIER 74 75 ! Specific behaviour for Shallow Water (1 vertical layer) case: 76 if (llm.eq.1) then 77 78 ! Compute pks(:),pk(:),pkf(:) 79 ijb=ij_begin 80 ije=ij_end 81 !$OMP DO SCHEDULE(STATIC) 82 DO ij=ijb, ije 83 pks(ij) = (cpp/preff) * ps(ij) 88 84 pk(ij,1) = .5*pks(ij) 89 pkf(ij,1)=pk(ij,1)90 91 !$OMP ENDDO85 if (present(pkf)) pkf(ij,1)=pk(ij,1) 86 ENDDO 87 !$OMP ENDDO 92 88 93 !$OMP MASTER 94 if (pole_nord) then 95 DO ij = 1, iim 96 ppn(ij) = aire( ij ) * pks( ij ) 97 ENDDO 98 xpn = SSUM(iim,ppn,1) /apoln 99 100 DO ij = 1, iip1 101 pks( ij ) = xpn 102 pk(ij,1) = .5*pks(ij) 103 pkf(ij,1)=pk(ij,1) 104 ENDDO 105 endif 106 107 if (pole_sud) then 108 DO ij = 1, iim 109 pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) 110 ENDDO 111 xps = SSUM(iim,pps,1) /apols 112 113 DO ij = 1, iip1 114 pks( ij+ip1jm ) = xps 115 pk(ij+ip1jm,1)=.5*pks(ij+ip1jm) 116 pkf(ij+ip1jm,1)=pk(ij+ip1jm,1) 117 ENDDO 118 endif 119 !$OMP END MASTER 120 !$OMP BARRIER 121 jjb=jj_begin 122 jje=jj_end 123 CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, 124 & 2, 1, .TRUE., 1 ) 89 !$OMP BARRIER 90 if (present(pkf)) then 91 jjb=jj_begin 92 jje=jj_end 93 CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, & 94 2, 1, .TRUE., 1 ) 95 end if 125 96 126 127 128 97 ! our work is done, exit routine 98 return 99 endif ! of if (llm.eq.1) 129 100 130 !!!! General case:101 ! General case: 131 102 132 c ------------- 133 c Calcul de pks 134 c ------------- 135 136 ijb=ij_begin 137 ije=ij_end 103 ! ------------- 104 ! Calcul de pks 105 ! ------------- 138 106 139 c$OMP DO SCHEDULE(STATIC) 140 DO ij = ijb, ije 141 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 142 ENDDO 143 c$OMP ENDDO 144 c Synchro OPENMP ici 107 ijb=ij_begin 108 ije=ij_end 145 109 146 c$OMP MASTER 147 if (pole_nord) then 148 DO ij = 1, iim 149 ppn(ij) = aire( ij ) * pks( ij ) 150 ENDDO 151 xpn = SSUM(iim,ppn,1) /apoln 152 153 DO ij = 1, iip1 154 pks( ij ) = xpn 155 ENDDO 156 endif 157 158 if (pole_sud) then 159 DO ij = 1, iim 160 pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) 161 ENDDO 162 xps = SSUM(iim,pps,1) /apols 163 164 DO ij = 1, iip1 165 pks( ij+ip1jm ) = xps 166 ENDDO 167 endif 168 c$OMP END MASTER 169 c$OMP BARRIER 170 c 171 c 172 c .... Calcul de pk pour la couche l 173 c -------------------------------------------- 174 c 175 dum1 = cpp * (2*preff)**(-kappa) 176 DO l = 1, llm-1 177 c$OMP DO SCHEDULE(STATIC) 178 DO ij = ijb, ije 179 pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa 180 ENDDO 181 c$OMP ENDDO NOWAIT 182 ENDDO 110 !$OMP DO SCHEDULE(STATIC) 111 DO ij = ijb, ije 112 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 113 ENDDO 114 !$OMP ENDDO 115 ! Synchro OPENMP ici 183 116 184 c .... Calcul de pk pour la couche l = llm .. 185 c (on met la meme distance (en log pression) entre Pk(llm) 186 c et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) 117 !$OMP BARRIER 118 ! 119 ! 120 ! .... Calcul de pk pour la couche l 121 ! -------------------------------------------- 122 ! 123 dum1 = cpp * (2*preff)**(-kappa) 124 DO l = 1, llm-1 125 !$OMP DO SCHEDULE(STATIC) 126 DO ij = ijb, ije 127 pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa 128 ENDDO 129 !$OMP ENDDO NOWAIT 130 ENDDO 187 131 188 c$OMP DO SCHEDULE(STATIC) 189 DO ij = ijb, ije 190 pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2) 191 ENDDO 192 c$OMP ENDDO NOWAIT 132 ! .... Calcul de pk pour la couche l = llm .. 133 ! (on met la meme distance (en log pression) entre Pk(llm) 134 ! et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) 193 135 136 !$OMP DO SCHEDULE(STATIC) 137 DO ij = ijb, ije 138 pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2) 139 ENDDO 140 !$OMP ENDDO NOWAIT 194 141 195 c calcul de pkf 196 c ------------- 197 c CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) 198 DO l = 1, llm 199 c$OMP DO SCHEDULE(STATIC) 200 DO ij = ijb, ije 201 pkf(ij,l)=pk(ij,l) 202 ENDDO 203 c$OMP ENDDO NOWAIT 204 ENDDO 142 if (present(pkf)) then 143 ! calcul de pkf 205 144 206 c$OMP BARRIER 207 208 jjb=jj_begin 209 jje=jj_end 210 CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, 211 & 2, 1, .TRUE., 1 ) 212 213 c EST-CE UTILE ?? : calcul de beta 214 c -------------------------------- 215 DO l = 2, llm 216 c$OMP DO SCHEDULE(STATIC) 217 DO ij = ijb, ije 218 beta(ij,l) = pk(ij,l) / pk(ij,l-1) 219 ENDDO 220 c$OMP ENDDO NOWAIT 221 ENDDO 145 DO l = 1, llm 146 !$OMP DO SCHEDULE(STATIC) 147 DO ij = ijb, ije 148 pkf(ij,l)=pk(ij,l) 149 ENDDO 150 !$OMP ENDDO NOWAIT 151 ENDDO 222 152 223 RETURN 224 END 153 !$OMP BARRIER 154 155 jjb=jj_begin 156 jje=jj_end 157 CALL filtreg_p ( pkf,jjb_u,jje_u,jjb,jje, jmp1, llm, & 158 2, 1, .TRUE., 1 ) 159 end if 160 161 END SUBROUTINE exner_milieu_loc 162 163 end module exner_milieu_loc_m -
LMDZ5/trunk/libf/dyn3dmem/gcm.F
r1995 r2021 98 98 REAL,ALLOCATABLE,SAVE :: ps(:) ! pression au sol 99 99 c REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches 100 c REAL pks(ip1jmp1) ! exner au sol101 c REAL pk(ip1jmp1,llm) ! exner au milieu des couches102 c REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches103 100 REAL,ALLOCATABLE,SAVE :: masse(:,:) ! masse d'air 104 101 REAL,ALLOCATABLE,SAVE :: phis(:) ! geopotentiel au sol … … 124 121 data call_iniphys/.true./ 125 122 126 c REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)127 123 c+jld variables test conservation energie 128 124 c REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) -
LMDZ5/trunk/libf/dyn3dmem/guide_loc_mod.F90
r1907 r2021 329 329 !======================================================================= 330 330 SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps) 331 use exner_hyb_loc_m, only: exner_hyb_loc 332 use exner_milieu_loc_m, only: exner_milieu_loc 331 333 USE parallel_lmdz 332 334 USE control_mod … … 353 355 REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: f_addv ! var aux: champ de guidage 354 356 ! Variables pour fonction Exner (P milieu couche) 355 REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: pk, pkf 356 REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: alpha, beta 357 REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: pk 357 358 REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: pks 358 359 REAL :: unskap … … 399 400 ALLOCATE(f_addv(ijb_v:ije_v,llm) ) 400 401 ALLOCATE(pk(iip1,jjb_u:jje_u,llm) ) 401 ALLOCATE(pkf(iip1,jjb_u:jje_u,llm) )402 ALLOCATE(alpha(iip1,jjb_u:jje_u,llm) )403 ALLOCATE(beta(iip1,jjb_u:jje_u,llm) )404 402 ALLOCATE(pks(iip1,jjb_u:jje_u) ) 405 403 ALLOCATE(p(ijb_u:ije_u,llmp1) ) … … 539 537 CALL pression_loc( ijnb_u, ap, bp, ps, p ) 540 538 if (pressure_exner) then 541 CALL exner_hyb_loc(ip1jmp1,ps,p, alpha,beta,pks,pk,pkf)539 CALL exner_hyb_loc(ip1jmp1,ps,p,pks,pk) 542 540 else 543 CALL exner_milieu_loc(ip1jmp1,ps,p, beta,pks,pk,pkf)541 CALL exner_milieu_loc(ip1jmp1,ps,p,pks,pk) 544 542 endif 545 543 !$OMP BARRIER … … 894 892 !======================================================================= 895 893 SUBROUTINE guide_interp(psi,teta) 894 use exner_hyb_loc_m, only: exner_hyb_loc 895 use exner_milieu_loc_m, only: exner_milieu_loc 896 896 USE parallel_lmdz 897 897 USE mod_hallo … … 919 919 REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: pbary 920 920 ! Variables pour fonction Exner (P milieu couche) 921 REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: pk, pkf 922 REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: alpha, beta 921 REAL, ALLOCATABLE, SAVE,DIMENSION (:,:,:) :: pk 923 922 REAL ,ALLOCATABLE, SAVE, DIMENSION (:,:) :: pks 924 923 REAL :: unskap … … 949 948 ALLOCATE(pbary(iip1,jjb_v:jje_v,llm) ) 950 949 ALLOCATE(pk(iip1,jjb_u:jje_u,llm) ) 951 ALLOCATE(pkf(iip1,jjb_u:jje_u,llm) )952 ALLOCATE(alpha(iip1,jjb_u:jje_u,llm) )953 ALLOCATE(beta(iip1,jjb_u:jje_u,llm) )954 950 ALLOCATE(pks (iip1,jjb_u:jje_u) ) 955 951 ALLOCATE(qsat(ijb_u:ije_u,llm) ) … … 1032 1028 CALL pression_loc( ijnb_u, ap, bp, psi, p ) 1033 1029 if (disvert_type==1) then 1034 CALL exner_hyb_loc(ijnb_u,psi,p, alpha,beta,pks,pk,pkf)1030 CALL exner_hyb_loc(ijnb_u,psi,p,pks,pk) 1035 1031 else ! we assume that we are in the disvert_type==2 case 1036 CALL exner_milieu_loc(ijnb_u,psi,p, beta,pks,pk,pkf)1032 CALL exner_milieu_loc(ijnb_u,psi,p,pks,pk) 1037 1033 endif 1038 1034 unskap=1./kappa -
LMDZ5/trunk/libf/dyn3dmem/iniacademic_loc.F90
r1907 r2021 4 4 SUBROUTINE iniacademic_loc(vcov,ucov,teta,q,masse,ps,phis,time_0) 5 5 6 use exner_hyb_m, only: exner_hyb 7 use exner_milieu_m, only: exner_milieu 6 8 USE filtreg_mod 7 9 USE infotrac, ONLY : nqtot … … 58 60 REAL pks(ip1jmp1) ! exner au sol 59 61 REAL pk(ip1jmp1,llm) ! exner au milieu des couches 60 REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches61 62 REAL phi(ip1jmp1,llm) ! geopotentiel 62 63 REAL ddsin,zsig,tetapv,w_pv ! variables auxiliaires … … 75 76 76 77 REAL zdtvr 77 real,allocatable :: alpha(:,:),beta(:,:)78 78 79 79 character(len=*),parameter :: modname="iniacademic" … … 219 219 allocate(masse_glo(ip1jmp1,llm)) 220 220 allocate(phis_glo(ip1jmp1)) 221 allocate(alpha(ip1jmp1,llm))222 allocate(beta(ip1jmp1,llm))223 221 224 222 ! surface pressure … … 238 236 CALL pression ( ip1jmp1, ap, bp, ps_glo, p ) 239 237 if (pressure_exner) then 240 CALL exner_hyb( ip1jmp1, ps_glo, p, alpha,beta, pks, pk, pkf)238 CALL exner_hyb( ip1jmp1, ps_glo, p, pks, pk ) 241 239 else 242 call exner_milieu(ip1jmp1,ps_glo,p, beta,pks,pk,pkf)240 call exner_milieu(ip1jmp1,ps_glo,p,pks,pk) 243 241 endif 244 242 CALL massdair(p,masse_glo) … … 301 299 deallocate(ps_glo) 302 300 deallocate(phis_glo) 303 deallocate(alpha)304 deallocate(beta)305 301 ENDIF ! of IF (.NOT. read_start) 306 302 endif academic_case -
LMDZ5/trunk/libf/dyn3dmem/leapfrog_loc.F
r1987 r2021 31 31 USE call_calfis_mod, ONLY : call_calfis 32 32 USE leapfrog_mod 33 use exner_hyb_loc_m, only: exner_hyb_loc 34 use exner_milieu_loc_m, only: exner_milieu_loc 33 35 IMPLICIT NONE 34 36 … … 156 158 character*10 string10 157 159 158 ! REAL,SAVE,ALLOCATABLE :: alpha(:,:),beta(:,:)159 160 ! REAL,SAVE,ALLOCATABLE :: flxw(:,:) ! flux de masse verticale 160 161 … … 261 262 ! ALLOCATE(dqfi_tmp(iip1,llm,nqtot)) 262 263 ! ALLOCATE(finvmaold(ijb_u:ije_u,llm)) 263 ! ALLOCATE(alpha(ijb_u:ije_u,llm),beta(ijb_u:ije_u,llm))264 264 ! ALLOCATE(flxw(ijb_u:ije_u,llm)) 265 265 ! ALLOCATE(ecin(ijb_u:ije_u,llm),ecin0(ijb_u:ije_u,llm)) … … 284 284 c$OMP END MASTER 285 285 if (pressure_exner) then 286 CALL exner_hyb_loc( ijnb_u, ps, p, alpha,beta,pks, pk, pkf)286 CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf) 287 287 else 288 CALL exner_milieu_loc( ijnb_u, ps, p, beta,pks, pk, pkf )288 CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf ) 289 289 endif 290 290 c----------------------------------------------------------------------- … … 780 780 781 781 ! c$OMP BARRIER 782 ! CALL exner_hyb_loc( ip1jmp1, ps, p, alpha,beta,pks, pk, pkf )782 ! CALL exner_hyb_loc( ip1jmp1, ps, p,pks, pk, pkf ) 783 783 ! c$OMP BARRIER 784 784 ! jD_cur = jD_ref + day_ini - day_ref … … 1135 1135 c$OMP BARRIER 1136 1136 if (pressure_exner) then 1137 CALL exner_hyb_loc( ijnb_u, ps, p, alpha,beta,pks, pk, pkf )1137 CALL exner_hyb_loc( ijnb_u, ps, p, pks, pk, pkf ) 1138 1138 else 1139 CALL exner_milieu_loc( ijnb_u, ps, p, beta,pks, pk, pkf )1139 CALL exner_milieu_loc( ijnb_u, ps, p, pks, pk, pkf ) 1140 1140 endif 1141 1141 c$OMP BARRIER -
LMDZ5/trunk/libf/dyn3dmem/leapfrog_mod.F90
r1987 r2021 27 27 REAL,POINTER,SAVE :: dq(:,:,:) 28 28 REAL,POINTER,SAVE :: finvmaold(:,:) 29 REAL,POINTER,SAVE :: alpha(:,:)30 REAL,POINTER,SAVE :: beta(:,:)31 29 REAL,POINTER,SAVE :: flxw(:,:) 32 30 REAL,POINTER,SAVE :: unat(:,:) … … 79 77 CALL allocate_u(dq,llm,nqtot,d) 80 78 CALL allocate_u(finvmaold,llm,d) 81 CALL allocate_u(alpha,llm,d)82 CALL allocate_u(beta,llm,d)83 79 CALL allocate_u(flxw,llm,d) 84 80 CALL allocate_u(unat,llm,d) … … 129 125 CALL switch_u(dq,distrib_caldyn,dist) 130 126 CALL switch_u(finvmaold,distrib_caldyn,dist) 131 CALL switch_u(alpha,distrib_caldyn,dist)132 CALL switch_u(beta,distrib_caldyn,dist)133 127 CALL switch_u(flxw,distrib_caldyn,dist) 134 128 CALL switch_u(unat,distrib_caldyn,dist) -
LMDZ5/trunk/libf/dyn3dpar/exner_hyb_p_m.F90
r1992 r2021 1 ! 2 ! $Id $ 3 ! 4 SUBROUTINE exner_hyb_p ( ngrid, ps, p,alpha,beta, pks, pk, pkf ) 5 c 6 c Auteurs : P.Le Van , Fr. Hourdin . 7 c .......... 8 c 9 c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 10 c .... alpha,beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... 11 c 12 c ************************************************************************ 13 c Calcule la fonction d'Exner pk = Cp * p ** kappa , aux milieux des 14 c couches . Pk(l) sera calcule aux milieux des couches l ,entre les 15 c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 16 c ************************************************************************ 17 c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 18 c la pression et la fonction d'Exner au sol . 19 c 20 c -------- z 21 c A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et 22 c ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) 23 c ( voir note de Fr.Hourdin ) , 24 c 25 c on determine successivement , du haut vers le bas des couches, les 26 c coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 27 c puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, 28 c pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . 29 c 30 c 31 USE parallel_lmdz 32 IMPLICIT NONE 33 c 34 #include "dimensions.h" 35 #include "paramet.h" 36 #include "comconst.h" 37 #include "comgeom.h" 38 #include "comvert.h" 39 #include "serre.h" 1 module exner_hyb_p_m 40 2 41 INTEGER ngrid 42 REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) 43 REAL ps(ngrid),pks(ngrid), alpha(ngrid,llm),beta(ngrid,llm) 3 IMPLICIT NONE 44 4 45 c .... variables locales ...5 contains 46 6 47 INTEGER l, ij 48 REAL unpl2k,dellta 7 SUBROUTINE exner_hyb_p ( ngrid, ps, p, pks, pk, pkf ) 49 8 50 REAL ppn(iim),pps(iim) 51 REAL xpn, xps 52 REAL SSUM 53 EXTERNAL SSUM 54 INTEGER ije,ijb,jje,jjb 55 logical,save :: firstcall=.true. 56 !$OMP THREADPRIVATE(firstcall) 57 character(len=*),parameter :: modname="exner_hyb_p" 58 c 9 ! Auteurs : P.Le Van , Fr. Hourdin . 10 ! .......... 11 ! 12 ! .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 13 ! .... pks,pk,pkf sont des argum.de sortie au sous-prog ... 14 ! 15 ! ************************************************************************ 16 ! Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 17 ! couches . Pk(l) sera calcule aux milieux des couches l ,entre les 18 ! pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 19 ! ************************************************************************ 20 ! .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 21 ! la pression et la fonction d'Exner au sol . 22 ! 23 ! -------- z 24 ! A partir des relations ( 1 ) p*dz(pk) = kappa *pk*dz(p) et 25 ! ( 2 ) pk(l) = alpha(l)+ beta(l)*pk(l-1) 26 ! ( voir note de Fr.Hourdin ) , 27 ! 28 ! on determine successivement , du haut vers le bas des couches, les 29 ! coef. alpha(llm),beta(llm) .,.,alpha(l),beta(l),,,alpha(2),beta(2), 30 ! puis pk(ij,1). Ensuite ,on calcule,du bas vers le haut des couches, 31 ! pk(ij,l) donne par la relation (2), pour l = 2 a l = llm . 32 ! 33 ! 34 USE parallel_lmdz 35 ! 36 include "dimensions.h" 37 include "paramet.h" 38 include "comconst.h" 39 include "comgeom.h" 40 include "comvert.h" 41 include "serre.h" 59 42 60 ! Sanity check 61 if (firstcall) then 62 ! sanity checks for Shallow Water case (1 vertical layer) 63 if (llm.eq.1) then 43 INTEGER ngrid 44 REAL p(ngrid,llmp1),pk(ngrid,llm) 45 REAL, optional:: pkf(ngrid,llm) 46 REAL ps(ngrid),pks(ngrid) 47 REAL alpha(ngrid,llm),beta(ngrid,llm) 48 49 ! .... variables locales ... 50 51 INTEGER l, ij 52 REAL unpl2k,dellta 53 54 INTEGER ije,ijb,jje,jjb 55 logical,save :: firstcall=.true. 56 !$OMP THREADPRIVATE(firstcall) 57 character(len=*),parameter :: modname="exner_hyb_p" 58 59 ! Sanity check 60 if (firstcall) then 61 ! sanity checks for Shallow Water case (1 vertical layer) 62 if (llm.eq.1) then 64 63 if (kappa.ne.1) then 65 call abort_gcm(modname,66 &"kappa!=1 , but running in Shallow Water mode!!",42)64 call abort_gcm(modname, & 65 "kappa!=1 , but running in Shallow Water mode!!",42) 67 66 endif 68 67 if (cpp.ne.r) then 69 call abort_gcm(modname,70 &"cpp!=r , but running in Shallow Water mode!!",42)68 call abort_gcm(modname, & 69 "cpp!=r , but running in Shallow Water mode!!",42) 71 70 endif 72 71 endif ! of if (llm.eq.1) 73 72 74 75 73 firstcall=.false. 74 endif ! of if (firstcall) 76 75 77 c$OMP BARRIER76 !$OMP BARRIER 78 77 79 ! Specific behaviour for Shallow Water (1 vertical layer) case 80 81 82 83 84 85 !$OMP DO SCHEDULE(STATIC)86 87 pks(ij) =(cpp/preff)*ps(ij)78 ! Specific behaviour for Shallow Water (1 vertical layer) case: 79 if (llm.eq.1) then 80 81 ! Compute pks(:),pk(:),pkf(:) 82 ijb=ij_begin 83 ije=ij_end 84 !$OMP DO SCHEDULE(STATIC) 85 DO ij=ijb, ije 86 pks(ij) = (cpp/preff) * ps(ij) 88 87 pk(ij,1) = .5*pks(ij) 89 pkf(ij,1)=pk(ij,1)90 91 !$OMP ENDDO88 if (present(pkf)) pkf(ij,1)=pk(ij,1) 89 ENDDO 90 !$OMP ENDDO 92 91 93 !$OMP MASTER 94 if (pole_nord) then 95 DO ij = 1, iim 96 ppn(ij) = aire( ij ) * pks( ij ) 97 ENDDO 98 xpn = SSUM(iim,ppn,1) /apoln 99 100 DO ij = 1, iip1 101 pks( ij ) = xpn 102 pk(ij,1) = .5*pks(ij) 103 pkf(ij,1)=pk(ij,1) 104 ENDDO 105 endif 106 107 if (pole_sud) then 108 DO ij = 1, iim 109 pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) 110 ENDDO 111 xps = SSUM(iim,pps,1) /apols 112 113 DO ij = 1, iip1 114 pks( ij+ip1jm ) = xps 115 pk(ij+ip1jm,1)=.5*pks(ij+ip1jm) 116 pkf(ij+ip1jm,1)=pk(ij+ip1jm,1) 117 ENDDO 118 endif 119 !$OMP END MASTER 120 !$OMP BARRIER 121 jjb=jj_begin 122 jje=jj_end 123 CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) 92 !$OMP BARRIER 93 if (present(pkf)) then 94 jjb=jj_begin 95 jje=jj_end 96 CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) 97 end if 124 98 125 126 127 99 ! our work is done, exit routine 100 return 101 endif ! of if (llm.eq.1) 128 102 129 !!!! General case:103 ! General case: 130 104 131 unpl2k = 1.+ 2.* kappa 132 c 133 ijb=ij_begin 134 ije=ij_end 105 unpl2k = 1.+ 2.* kappa 135 106 136 c$OMP DO SCHEDULE(STATIC) 137 DO ij = ijb, ije 138 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 139 ENDDO 140 c$OMP ENDDO 141 c Synchro OPENMP ici 107 ! ------------- 108 ! Calcul de pks 109 ! ------------- 142 110 143 c$OMP MASTER 144 if (pole_nord) then 145 DO ij = 1, iim 146 ppn(ij) = aire( ij ) * pks( ij ) 147 ENDDO 148 xpn = SSUM(iim,ppn,1) /apoln 149 150 DO ij = 1, iip1 151 pks( ij ) = xpn 152 ENDDO 153 endif 154 155 if (pole_sud) then 156 DO ij = 1, iim 157 pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) 158 ENDDO 159 xps = SSUM(iim,pps,1) /apols 160 161 DO ij = 1, iip1 162 pks( ij+ip1jm ) = xps 163 ENDDO 164 endif 165 c$OMP END MASTER 166 c$OMP BARRIER 167 c 168 c 169 c .... Calcul des coeff. alpha et beta pour la couche l = llm .. 170 c 171 c$OMP DO SCHEDULE(STATIC) 172 DO ij = ijb,ije 111 ijb=ij_begin 112 ije=ij_end 113 114 !$OMP DO SCHEDULE(STATIC) 115 DO ij = ijb, ije 116 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 117 ENDDO 118 !$OMP ENDDO 119 ! Synchro OPENMP ici 120 121 !$OMP BARRIER 122 ! 123 ! 124 ! .... Calcul des coeff. alpha et beta pour la couche l = llm .. 125 ! 126 !$OMP DO SCHEDULE(STATIC) 127 DO ij = ijb,ije 173 128 alpha(ij,llm) = 0. 174 129 beta (ij,llm) = 1./ unpl2k 175 ENDDO 176 c$OMP ENDDO NOWAIT 177 c 178 c ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... 179 c 180 DO l = llm -1 , 2 , -1 181 c 182 c$OMP DO SCHEDULE(STATIC) 183 DO ij = ijb, ije 184 dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) 185 alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) 186 beta (ij,l) = p(ij,l ) / dellta 187 ENDDO 188 c$OMP ENDDO NOWAIT 189 c 190 ENDDO 130 ENDDO 131 !$OMP ENDDO NOWAIT 132 ! 133 ! ... Calcul des coeff. alpha et beta pour l = llm-1 a l = 2 ... 134 ! 135 DO l = llm -1 , 2 , -1 136 ! 137 !$OMP DO SCHEDULE(STATIC) 138 DO ij = ijb, ije 139 dellta = p(ij,l)* unpl2k + p(ij,l+1)* ( beta(ij,l+1)-unpl2k ) 140 alpha(ij,l) = - p(ij,l+1) / dellta * alpha(ij,l+1) 141 beta (ij,l) = p(ij,l ) / dellta 142 ENDDO 143 !$OMP ENDDO NOWAIT 144 ENDDO 191 145 192 c 193 c *********************************************************************** 194 c ..... Calcul de pk pour la couche 1 , pres du sol .... 195 c 196 c$OMP DO SCHEDULE(STATIC) 197 DO ij = ijb, ije 198 pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / 199 * ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) 200 ENDDO 201 c$OMP ENDDO NOWAIT 202 c 203 c ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ 204 c 205 DO l = 2, llm 206 c$OMP DO SCHEDULE(STATIC) 207 DO ij = ijb, ije 208 pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) 209 ENDDO 210 c$OMP ENDDO NOWAIT 211 ENDDO 212 c 213 c 214 c CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) 215 DO l = 1, llm 216 c$OMP DO SCHEDULE(STATIC) 217 DO ij = ijb, ije 218 pkf(ij,l)=pk(ij,l) 219 ENDDO 220 c$OMP ENDDO NOWAIT 221 ENDDO 146 ! *********************************************************************** 147 ! ..... Calcul de pk pour la couche 1 , pres du sol .... 148 ! 149 !$OMP DO SCHEDULE(STATIC) 150 DO ij = ijb, ije 151 pk(ij,1) = ( p(ij,1)*pks(ij) - 0.5*alpha(ij,2)*p(ij,2) ) / & 152 ( p(ij,1)* (1.+kappa) + 0.5*( beta(ij,2)-unpl2k )* p(ij,2) ) 153 ENDDO 154 !$OMP ENDDO NOWAIT 155 ! 156 ! ..... Calcul de pk(ij,l) , pour l = 2 a l = llm ........ 157 ! 158 DO l = 2, llm 159 !$OMP DO SCHEDULE(STATIC) 160 DO ij = ijb, ije 161 pk(ij,l) = alpha(ij,l) + beta(ij,l) * pk(ij,l-1) 162 ENDDO 163 !$OMP ENDDO NOWAIT 164 ENDDO 222 165 223 c$OMP BARRIER 224 225 jjb=jj_begin 226 jje=jj_end 227 CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) 228 166 if (present(pkf)) then 167 ! calcul de pkf 229 168 230 RETURN 231 END 169 DO l = 1, llm 170 !$OMP DO SCHEDULE(STATIC) 171 DO ij = ijb, ije 172 pkf(ij,l)=pk(ij,l) 173 ENDDO 174 !$OMP ENDDO NOWAIT 175 ENDDO 176 177 !$OMP BARRIER 178 179 jjb=jj_begin 180 jje=jj_end 181 CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) 182 end if 183 184 END SUBROUTINE exner_hyb_p 185 186 end module exner_hyb_p_m -
LMDZ5/trunk/libf/dyn3dpar/exner_milieu_p_m.F90
r1992 r2021 1 ! 2 ! $Id $ 3 ! 4 SUBROUTINE exner_milieu_p ( ngrid, ps, p,beta, pks, pk, pkf ) 5 c 6 c Auteurs : F. Forget , Y. Wanherdrick 7 c P.Le Van , Fr. Hourdin . 8 c .......... 9 c 10 c .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 11 c .... beta, pks,pk,pkf sont des argum.de sortie au sous-prog ... 12 c 13 c ************************************************************************ 14 c Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 15 c couches . Pk(l) sera calcule aux milieux des couches l ,entre les 16 c pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 17 c ************************************************************************ 18 c .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 19 c la pression et la fonction d'Exner au sol . 20 c 21 c WARNING : CECI est une version speciale de exner_hyb originale 22 c Utilise dans la version martienne pour pouvoir 23 c tourner avec des coordonnees verticales complexe 24 c => Il ne verifie PAS la condition la proportionalite en 25 c energie totale/ interne / potentielle (F.Forget 2001) 26 c ( voir note de Fr.Hourdin ) , 27 c 28 USE parallel_lmdz 29 IMPLICIT NONE 30 c 31 #include "dimensions.h" 32 #include "paramet.h" 33 #include "comconst.h" 34 #include "comgeom.h" 35 #include "comvert.h" 36 #include "serre.h" 1 module exner_milieu_p_m 37 2 38 INTEGER ngrid 39 REAL p(ngrid,llmp1),pk(ngrid,llm),pkf(ngrid,llm) 40 REAL ps(ngrid),pks(ngrid), beta(ngrid,llm) 3 IMPLICIT NONE 41 4 42 c .... variables locales ...5 contains 43 6 44 INTEGER l, ij 45 REAL dum1 7 SUBROUTINE exner_milieu_p ( ngrid, ps, p, pks, pk, pkf ) 8 ! 9 ! Auteurs : F. Forget , Y. Wanherdrick 10 ! P.Le Van , Fr. Hourdin . 11 ! .......... 12 ! 13 ! .... ngrid, ps,p sont des argum.d'entree au sous-prog ... 14 ! .... pks,pk,pkf sont des argum.de sortie au sous-prog ... 15 ! 16 ! ************************************************************************ 17 ! Calcule la fonction d'Exner pk = Cp * (p/preff) ** kappa , aux milieux des 18 ! couches . Pk(l) sera calcule aux milieux des couches l ,entre les 19 ! pressions p(l) et p(l+1) ,definis aux interfaces des llm couches . 20 ! ************************************************************************ 21 ! .. N.B : Au sommet de l'atmosphere, p(llm+1) = 0. , et ps et pks sont 22 ! la pression et la fonction d'Exner au sol . 23 ! 24 ! WARNING : CECI est une version speciale de exner_hyb originale 25 ! Utilise dans la version martienne pour pouvoir 26 ! tourner avec des coordonnees verticales complexe 27 ! => Il ne verifie PAS la condition la proportionalite en 28 ! energie totale/ interne / potentielle (F.Forget 2001) 29 ! ( voir note de Fr.Hourdin ) , 30 ! 31 USE parallel_lmdz 32 ! 33 include "dimensions.h" 34 include "paramet.h" 35 include "comconst.h" 36 include "comgeom.h" 37 include "comvert.h" 38 include "serre.h" 46 39 47 REAL ppn(iim),pps(iim) 48 REAL xpn, xps 49 REAL SSUM 50 EXTERNAL SSUM 51 INTEGER ije,ijb,jje,jjb 52 logical,save :: firstcall=.true. 53 !$OMP THREADPRIVATE(firstcall) 54 character(len=*),parameter :: modname="exner_milieu_p" 40 INTEGER ngrid 41 REAL p(ngrid,llmp1),pk(ngrid,llm) 42 REAL, optional:: pkf(ngrid,llm) 43 REAL ps(ngrid),pks(ngrid) 55 44 56 ! Sanity check 57 if (firstcall) then 58 ! sanity checks for Shallow Water case (1 vertical layer) 59 if (llm.eq.1) then 45 ! .... variables locales ... 46 47 INTEGER l, ij 48 REAL dum1 49 50 logical,save :: firstcall=.true. 51 !$OMP THREADPRIVATE(firstcall) 52 character(len=*),parameter :: modname="exner_milieu_p" 53 54 ! Sanity check 55 if (firstcall) then 56 ! sanity checks for Shallow Water case (1 vertical layer) 57 if (llm.eq.1) then 60 58 if (kappa.ne.1) then 61 call abort_gcm(modname,62 &"kappa!=1 , but running in Shallow Water mode!!",42)59 call abort_gcm(modname, & 60 "kappa!=1 , but running in Shallow Water mode!!",42) 63 61 endif 64 62 if (cpp.ne.r) then 65 call abort_gcm(modname,66 &"cpp!=r , but running in Shallow Water mode!!",42)63 call abort_gcm(modname, & 64 "cpp!=r , but running in Shallow Water mode!!",42) 67 65 endif 68 66 endif ! of if (llm.eq.1) 69 67 70 firstcall=.false. 71 endif ! of if (firstcall) 72 73 c$OMP BARRIER 68 firstcall=.false. 69 endif ! of if (firstcall) 74 70 75 ! Specific behaviour for Shallow Water (1 vertical layer) case 76 if (llm.eq.1) then 77 78 ! Compute pks(:),pk(:),pkf(:) 79 ijb=ij_begin 80 ije=ij_end 81 !$OMP DO SCHEDULE(STATIC) 82 DO ij=ijb, ije 83 pks(ij)=(cpp/preff)*ps(ij) 71 !$OMP BARRIER 72 73 ! Specific behaviour for Shallow Water (1 vertical layer) case: 74 if (llm.eq.1) then 75 76 ! Compute pks(:),pk(:),pkf(:) 77 ijb=ij_begin 78 ije=ij_end 79 !$OMP DO SCHEDULE(STATIC) 80 DO ij=ijb, ije 81 pks(ij) = (cpp/preff) * ps(ij) 84 82 pk(ij,1) = .5*pks(ij) 85 pkf(ij,1)=pk(ij,1)86 87 !$OMP ENDDO83 if (present(pkf)) pkf(ij,1)=pk(ij,1) 84 ENDDO 85 !$OMP ENDDO 88 86 89 !$OMP MASTER 90 if (pole_nord) then 91 DO ij = 1, iim 92 ppn(ij) = aire( ij ) * pks( ij ) 93 ENDDO 94 xpn = SSUM(iim,ppn,1) /apoln 95 96 DO ij = 1, iip1 97 pks( ij ) = xpn 98 pk(ij,1) = .5*pks(ij) 99 pkf(ij,1)=pk(ij,1) 100 ENDDO 101 endif 102 103 if (pole_sud) then 104 DO ij = 1, iim 105 pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) 106 ENDDO 107 xps = SSUM(iim,pps,1) /apols 108 109 DO ij = 1, iip1 110 pks( ij+ip1jm ) = xps 111 pk(ij+ip1jm,1)=.5*pks(ij+ip1jm) 112 pkf(ij+ip1jm,1)=pk(ij+ip1jm,1) 113 ENDDO 114 endif 115 !$OMP END MASTER 116 !$OMP BARRIER 117 jjb=jj_begin 118 jje=jj_end 119 CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) 87 !$OMP BARRIER 88 if (present(pkf)) then 89 jjb=jj_begin 90 jje=jj_end 91 CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) 92 end if 120 93 121 122 123 94 ! our work is done, exit routine 95 return 96 endif ! of if (llm.eq.1) 124 97 125 !!!! General case:98 ! General case: 126 99 127 c ------------- 128 c Calcul de pks 129 c ------------- 130 131 ijb=ij_begin 132 ije=ij_end 100 ! ------------- 101 ! Calcul de pks 102 ! ------------- 133 103 134 c$OMP DO SCHEDULE(STATIC) 135 DO ij = ijb, ije 136 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 137 ENDDO 138 c$OMP ENDDO 139 c Synchro OPENMP ici 104 ijb=ij_begin 105 ije=ij_end 140 106 141 c$OMP MASTER 142 if (pole_nord) then 143 DO ij = 1, iim 144 ppn(ij) = aire( ij ) * pks( ij ) 145 ENDDO 146 xpn = SSUM(iim,ppn,1) /apoln 147 148 DO ij = 1, iip1 149 pks( ij ) = xpn 150 ENDDO 151 endif 152 153 if (pole_sud) then 154 DO ij = 1, iim 155 pps(ij) = aire(ij+ip1jm) * pks(ij+ip1jm ) 156 ENDDO 157 xps = SSUM(iim,pps,1) /apols 158 159 DO ij = 1, iip1 160 pks( ij+ip1jm ) = xps 161 ENDDO 162 endif 163 c$OMP END MASTER 164 c$OMP BARRIER 165 c 166 c 167 c .... Calcul de pk pour la couche l 168 c -------------------------------------------- 169 c 170 dum1 = cpp * (2*preff)**(-kappa) 171 DO l = 1, llm-1 172 c$OMP DO SCHEDULE(STATIC) 173 DO ij = ijb, ije 174 pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa 175 ENDDO 176 c$OMP ENDDO NOWAIT 177 ENDDO 107 !$OMP DO SCHEDULE(STATIC) 108 DO ij = ijb, ije 109 pks(ij) = cpp * ( ps(ij)/preff ) ** kappa 110 ENDDO 111 !$OMP ENDDO 112 ! Synchro OPENMP ici 178 113 179 c .... Calcul de pk pour la couche l = llm .. 180 c (on met la meme distance (en log pression) entre Pk(llm) 181 c et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) 114 !$OMP BARRIER 115 ! 116 ! 117 ! .... Calcul de pk pour la couche l 118 ! -------------------------------------------- 119 ! 120 dum1 = cpp * (2*preff)**(-kappa) 121 DO l = 1, llm-1 122 !$OMP DO SCHEDULE(STATIC) 123 DO ij = ijb, ije 124 pk(ij,l) = dum1 * (p(ij,l) + p(ij,l+1))**kappa 125 ENDDO 126 !$OMP ENDDO NOWAIT 127 ENDDO 182 128 183 c$OMP DO SCHEDULE(STATIC) 184 DO ij = ijb, ije 185 pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2) 186 ENDDO 187 c$OMP ENDDO NOWAIT 129 ! .... Calcul de pk pour la couche l = llm .. 130 ! (on met la meme distance (en log pression) entre Pk(llm) 131 ! et Pk(llm -1) qu'entre Pk(llm-1) et Pk(llm-2) 188 132 133 !$OMP DO SCHEDULE(STATIC) 134 DO ij = ijb, ije 135 pk(ij,llm) = pk(ij,llm-1)**2 / pk(ij,llm-2) 136 ENDDO 137 !$OMP ENDDO NOWAIT 189 138 190 c calcul de pkf 191 c ------------- 192 c CALL SCOPY ( ngrid * llm, pk, 1, pkf, 1 ) 193 DO l = 1, llm 194 c$OMP DO SCHEDULE(STATIC) 195 DO ij = ijb, ije 196 pkf(ij,l)=pk(ij,l) 197 ENDDO 198 c$OMP ENDDO NOWAIT 199 ENDDO 139 if (present(pkf)) then 140 ! calcul de pkf 200 141 201 c$OMP BARRIER 202 203 jjb=jj_begin 204 jje=jj_end 205 CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) 206 207 c EST-CE UTILE ?? : calcul de beta 208 c -------------------------------- 209 DO l = 2, llm 210 c$OMP DO SCHEDULE(STATIC) 211 DO ij = ijb, ije 212 beta(ij,l) = pk(ij,l) / pk(ij,l-1) 213 ENDDO 214 c$OMP ENDDO NOWAIT 215 ENDDO 142 DO l = 1, llm 143 !$OMP DO SCHEDULE(STATIC) 144 DO ij = ijb, ije 145 pkf(ij,l)=pk(ij,l) 146 ENDDO 147 !$OMP ENDDO NOWAIT 148 ENDDO 216 149 217 RETURN 218 END 150 !$OMP BARRIER 151 152 jjb=jj_begin 153 jje=jj_end 154 CALL filtreg_p ( pkf,jjb,jje, jmp1, llm, 2, 1, .TRUE., 1 ) 155 end if 156 157 END SUBROUTINE exner_milieu_p 158 159 end module exner_milieu_p_m -
LMDZ5/trunk/libf/dyn3dpar/gcm.F
r1939 r2021 99 99 REAL ps(ip1jmp1) ! pression au sol 100 100 c REAL p (ip1jmp1,llmp1 ) ! pression aux interfac.des couches 101 c REAL pks(ip1jmp1) ! exner au sol102 c REAL pk(ip1jmp1,llm) ! exner au milieu des couches103 c REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches104 101 REAL masse(ip1jmp1,llm) ! masse d'air 105 102 REAL phis(ip1jmp1) ! geopotentiel au sol … … 125 122 data call_iniphys/.true./ 126 123 127 c REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm)128 124 c+jld variables test conservation energie 129 125 c REAL ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) -
LMDZ5/trunk/libf/dyn3dpar/guide_p_mod.F90
r1907 r2021 328 328 !======================================================================= 329 329 SUBROUTINE guide_main(itau,ucov,vcov,teta,q,masse,ps) 330 use exner_hyb_p_m, only: exner_hyb_p 331 use exner_milieu_p_m, only: exner_milieu_p 330 332 USE parallel_lmdz 331 333 USE control_mod … … 349 351 REAL, DIMENSION (ip1jmp1,llm) :: f_add ! var aux: champ de guidage 350 352 ! Variables pour fonction Exner (P milieu couche) 351 REAL, DIMENSION (iip1,jjp1,llm) :: pk, pkf 352 REAL, DIMENSION (iip1,jjp1,llm) :: alpha, beta 353 REAL, DIMENSION (iip1,jjp1,llm) :: pk 353 354 REAL, DIMENSION (iip1,jjp1) :: pks 354 355 REAL :: unskap … … 493 494 CALL pression_p( ip1jmp1, ap, bp, ps, p ) 494 495 if (pressure_exner) then 495 CALL exner_hyb_p(ip1jmp1,ps,p, alpha,beta,pks,pk,pkf)496 CALL exner_hyb_p(ip1jmp1,ps,p,pks,pk) 496 497 else 497 CALL exner_milieu_p(ip1jmp1,ps,p, beta,pks,pk,pkf)498 CALL exner_milieu_p(ip1jmp1,ps,p,pks,pk) 498 499 endif 499 500 unskap=1./kappa … … 689 690 !======================================================================= 690 691 SUBROUTINE guide_interp(psi,teta) 692 use exner_hyb_p_m, only: exner_hyb_p 693 use exner_milieu_p_m, only: exner_milieu_p 691 694 USE parallel_lmdz 692 695 USE mod_hallo … … 713 716 REAL, DIMENSION (iip1,jjm,llm) :: pbary 714 717 ! Variables pour fonction Exner (P milieu couche) 715 REAL, DIMENSION (iip1,jjp1,llm) :: pk, pkf 716 REAL, DIMENSION (iip1,jjp1,llm) :: alpha, beta 718 REAL, DIMENSION (iip1,jjp1,llm) :: pk 717 719 REAL, DIMENSION (iip1,jjp1) :: pks 718 720 REAL :: unskap … … 793 795 CALL pression_p( ip1jmp1, ap, bp, psi, p ) 794 796 if (pressure_exner) then 795 CALL exner_hyb_p(ip1jmp1,psi,p, alpha,beta,pks,pk,pkf)797 CALL exner_hyb_p(ip1jmp1,psi,p,pks,pk) 796 798 else 797 CALL exner_milieu_p(ip1jmp1,psi,p, beta,pks,pk,pkf)799 CALL exner_milieu_p(ip1jmp1,psi,p,pks,pk) 798 800 endif 799 801 unskap=1./kappa -
LMDZ5/trunk/libf/dyn3dpar/iniacademic.F90
r1907 r2021 4 4 SUBROUTINE iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) 5 5 6 use exner_hyb_m, only: exner_hyb 7 use exner_milieu_m, only: exner_milieu 6 8 USE filtreg_mod 7 9 USE infotrac, ONLY : nqtot … … 54 56 REAL pks(ip1jmp1) ! exner au sol 55 57 REAL pk(ip1jmp1,llm) ! exner au milieu des couches 56 REAL pkf(ip1jmp1,llm) ! exner filt.au milieu des couches57 58 REAL phi(ip1jmp1,llm) ! geopotentiel 58 59 REAL ddsin,zsig,tetapv,w_pv ! variables auxiliaires … … 70 71 integer idum 71 72 72 REAL alpha(ip1jmp1,llm),beta(ip1jmp1,llm),zdtvr73 REAL zdtvr 73 74 74 75 character(len=*),parameter :: modname="iniacademic" … … 223 224 CALL pression ( ip1jmp1, ap, bp, ps, p ) 224 225 if (pressure_exner) then 225 CALL exner_hyb( ip1jmp1, ps, p, alpha,beta, pks, pk, pkf)226 else 227 call exner_milieu(ip1jmp1,ps,p, beta,pks,pk,pkf)226 CALL exner_hyb( ip1jmp1, ps, p, pks, pk ) 227 else 228 call exner_milieu(ip1jmp1,ps,p,pks,pk) 228 229 endif 229 230 CALL massdair(p,masse) -
LMDZ5/trunk/libf/dyn3dpar/leapfrog_p.F
r1988 r2021 8 8 & time_0) 9 9 10 use exner_hyb_m, only: exner_hyb 11 use exner_milieu_m, only: exner_milieu 12 use exner_hyb_p_m, only: exner_hyb_p 13 use exner_milieu_p_m, only: exner_milieu_p 10 14 USE misc_mod 11 15 USE parallel_lmdz … … 149 153 character*10 string10 150 154 151 REAL,SAVE :: alpha(ip1jmp1,llm),beta(ip1jmp1,llm)152 155 REAL,SAVE :: flxw(ip1jmp1,llm) ! flux de masse verticale 153 156 … … 241 244 CALL pression ( ip1jmp1, ap, bp, ps, p ) 242 245 if (pressure_exner) then 243 CALL exner_hyb( ip1jmp1, ps, p, alpha,beta,pks, pk, pkf )246 CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf ) 244 247 else 245 CALL exner_milieu( ip1jmp1, ps, p, beta,pks, pk, pkf )248 CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf ) 246 249 endif 247 250 c$OMP END MASTER … … 705 708 c$OMP BARRIER 706 709 if (pressure_exner) then 707 CALL exner_hyb_p( ip1jmp1, ps, p, alpha,beta,pks, pk, pkf )710 CALL exner_hyb_p( ip1jmp1, ps, p,pks, pk, pkf ) 708 711 else 709 CALL exner_milieu_p( ip1jmp1, ps, p, beta,pks, pk, pkf )712 CALL exner_milieu_p( ip1jmp1, ps, p, pks, pk, pkf ) 710 713 endif 711 714 c$OMP BARRIER … … 918 921 c$OMP BARRIER 919 922 if (pressure_exner) then 920 CALL exner_hyb_p(ip1jmp1,ps,p, alpha,beta,pks,pk,pkf)923 CALL exner_hyb_p(ip1jmp1,ps,p,pks,pk,pkf) 921 924 else 922 CALL exner_milieu_p(ip1jmp1,ps,p, beta,pks,pk,pkf)925 CALL exner_milieu_p(ip1jmp1,ps,p,pks,pk,pkf) 923 926 endif 924 927 c$OMP BARRIER … … 1059 1062 c$OMP BARRIER 1060 1063 if (pressure_exner) then 1061 CALL exner_hyb_p( ip1jmp1, ps, p, alpha,beta,pks, pk, pkf )1064 CALL exner_hyb_p( ip1jmp1, ps, p, pks, pk, pkf ) 1062 1065 else 1063 CALL exner_milieu_p( ip1jmp1, ps, p, beta,pks, pk, pkf )1066 CALL exner_milieu_p( ip1jmp1, ps, p, pks, pk, pkf ) 1064 1067 endif 1065 1068 c$OMP BARRIER -
LMDZ5/trunk/libf/phylmd/etat0_netcdf.F90
r1907 r2021 29 29 USE netcdf, ONLY : NF90_OPEN, NF90_NOWRITE, NF90_CLOSE, NF90_NOERR 30 30 USE indice_sol_mod 31 use exner_hyb_m, only: exner_hyb 32 use exner_milieu_m, only: exner_milieu 33 use test_disvert_m, only: test_disvert 31 34 #endif 32 35 IMPLICIT NONE … … 74 77 CHARACTER(LEN=80) :: x, fmt 75 78 INTEGER :: i, j, l, ji 76 REAL, DIMENSION(iip1,jjp1,llm) :: alpha, beta,pk, pls, y79 REAL, DIMENSION(iip1,jjp1,llm) :: pk, pls, y 77 80 REAL, DIMENSION(ip1jmp1) :: pks 78 81 … … 150 153 151 154 CALL iniconst() 155 call test_disvert 152 156 CALL inigeom() 153 157 … … 253 257 CALL pression(ip1jmp1, ap, bp, psol, p3d) 254 258 if (pressure_exner) then 255 CALL exner_hyb(ip1jmp1, psol, p3d, alpha, beta, pks, pk, y)259 CALL exner_hyb(ip1jmp1, psol, p3d, pks, pk) 256 260 else 257 CALL exner_milieu(ip1jmp1,psol,p3d, beta,pks,pk,y)261 CALL exner_milieu(ip1jmp1,psol,p3d, pks,pk) 258 262 endif 259 263 pls(:,:,:)=preff*(pk(:,:,:)/cpp)**(1./kappa)
Note: See TracChangeset
for help on using the changeset viewer.