Changeset 5246 for LMDZ6/trunk/libf/dyn3d_common/limx.f90
- Timestamp:
- Oct 21, 2024, 2:58:45 PM (23 hours ago)
- File:
-
- 1 moved
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/trunk/libf/dyn3d_common/limx.f90
r5245 r5246 2 2 ! $Header$ 3 3 ! 4 5 c 6 c Auteurs: P.Le Van, F.Hourdin, F.Forget 7 c 8 c********************************************************************9 cShema d'advection " pseudo amont " .10 c********************************************************************11 cnq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg ....12 c 13 c 14 c--------------------------------------------------------------------15 16 c 17 18 19 20 c 21 c 22 cArguments:23 c----------24 realpente_max25 REALs0(ip1jmp1,llm),sm(ip1jmp1,llm)26 realsx(ip1jmp1,llm)27 c 28 c Local 29 c---------30 c 31 INTEGERij,l,j,i,iju,ijq,indu(ip1jmp1),niju32 integern0,iadvplus(ip1jmp1,llm),nl(llm)33 c 34 REALq(ip1jmp1,llm)35 realdxq(ip1jmp1,llm)4 SUBROUTINE limx(s0,sx,sm,pente_max) 5 ! 6 ! Auteurs: P.Le Van, F.Hourdin, F.Forget 7 ! 8 ! ******************************************************************** 9 ! Shema d'advection " pseudo amont " . 10 ! ******************************************************************** 11 ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg .... 12 ! 13 ! 14 ! -------------------------------------------------------------------- 15 IMPLICIT NONE 16 ! 17 include "dimensions.h" 18 include "paramet.h" 19 include "comgeom.h" 20 ! 21 ! 22 ! Arguments: 23 ! ---------- 24 real :: pente_max 25 REAL :: s0(ip1jmp1,llm),sm(ip1jmp1,llm) 26 real :: sx(ip1jmp1,llm) 27 ! 28 ! Local 29 ! --------- 30 ! 31 INTEGER :: ij,l,j,i,iju,ijq,indu(ip1jmp1),niju 32 integer :: n0,iadvplus(ip1jmp1,llm),nl(llm) 33 ! 34 REAL :: q(ip1jmp1,llm) 35 real :: dxq(ip1jmp1,llm) 36 36 37 37 38 REALnew_m,zm39 realdxqu(ip1jmp1)40 realadxqu(ip1jmp1),dxqmax(ip1jmp1)38 REAL :: new_m,zm 39 real :: dxqu(ip1jmp1) 40 real :: adxqu(ip1jmp1),dxqmax(ip1jmp1) 41 41 42 Logicalextremum,first43 42 Logical :: extremum,first 43 save first 44 44 45 REALSSUM,CVMGP,CVMGT46 integerismax,ismin47 45 REAL :: SSUM,CVMGP,CVMGT 46 integer :: ismax,ismin 47 EXTERNAL SSUM, ismin,ismax 48 48 49 49 data first/.true./ 50 50 51 51 52 53 54 55 56 57 52 DO l = 1,llm 53 DO ij=1,ip1jmp1 54 q(ij,l) = s0(ij,l) / sm ( ij,l ) 55 dxq(ij,l) = sx(ij,l) /sm(ij,l) 56 ENDDO 57 ENDDO 58 58 59 ccalcul de la pente a droite et a gauche de la maille59 ! calcul de la pente a droite et a gauche de la maille 60 60 61 62 63 64 65 66 67 61 do l = 1, llm 62 do ij=iip2,ip1jm-1 63 dxqu(ij)=q(ij+1,l)-q(ij,l) 64 enddo 65 do ij=iip1+iip1,ip1jm,iip1 66 dxqu(ij)=dxqu(ij-iim) 67 enddo 68 68 69 70 71 69 do ij=iip2,ip1jm 70 adxqu(ij)=abs(dxqu(ij)) 71 enddo 72 72 73 ccalcul de la pente maximum dans la maille en valeur absolue73 ! calcul de la pente maximum dans la maille en valeur absolue 74 74 75 76 77 75 do ij=iip2+1,ip1jm 76 dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij)) 77 enddo 78 78 79 80 81 79 do ij=iip1+iip1,ip1jm,iip1 80 dxqmax(ij-iim)=dxqmax(ij) 81 enddo 82 82 83 ccalcul de la pente avec limitation83 ! calcul de la pente avec limitation 84 84 85 86 if( dxqu(ij-1)*dxqu(ij).gt.0.87 &.and. dxq(ij,l)*dxqu(ij).gt.0.) then88 dxq(ij,l)=89 &sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l))90 91 cextremum local92 93 94 95 96 97 85 do ij=iip2+1,ip1jm 86 if( dxqu(ij-1)*dxqu(ij).gt.0. & 87 .and. dxq(ij,l)*dxqu(ij).gt.0.) then 88 dxq(ij,l)= & 89 sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l)) 90 else 91 ! extremum local 92 dxq(ij,l)=0. 93 endif 94 enddo 95 do ij=iip1+iip1,ip1jm,iip1 96 dxq(ij-iim,l)=dxq(ij,l) 97 enddo 98 98 99 100 101 99 DO ij=1,ip1jmp1 100 sx(ij,l) = dxq(ij,l)*sm(ij,l) 101 ENDDO 102 102 103 103 ENDDO 104 104 105 106 END 105 RETURN 106 END SUBROUTINE limx
Note: See TracChangeset
for help on using the changeset viewer.