Changeset 2021 for LMDZ5/trunk/libf/dyn3dmem
- Timestamp:
- Apr 25, 2014, 12:20:14 PM (10 years ago)
- Location:
- LMDZ5/trunk/libf/dyn3dmem
- Files:
-
- 6 edited
- 2 moved
Legend:
- Unmodified
- Added
- Removed
-
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)
Note: See TracChangeset
for help on using the changeset viewer.