Changeset 5105 for LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limx.f90

Timestamp:

Jul 23, 2024, 7:14:34 PM (8 weeks ago)

Author:

abarral

Message:

Replace 1DUTILS.h by module lmdz_1dutils.f90
Replace 1DConv.h by module lmdz_old_1dconv.f90 (it's only used by old_* files)
Convert *.F to *.f90
Fix gradsdef.h formatting
Remove unnecessary "RETURN" at the end of functions/subroutines

File:

• LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limx.f90 (moved) (moved from LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limx.F) (1 diff)

LMDZ6/branches/Amaury_dev/libf/dyn3d_common/limx.f90

@@ -2 +2 @@
 ! $Header$
 
-      SUBROUTINE limx(s0,sx,sm,pente_max)
-c
-c     Auteurs:   P.Le Van, F.Hourdin, F.Forget 
-c
-c    ********************************************************************
-c     Shema  d'advection " pseudo amont " .
-c    ********************************************************************
-c     nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
-c
-c
-c   --------------------------------------------------------------------
-      IMPLICIT NONE
-c
-      include "dimensions.h"
-      include "paramet.h"
-      include "comgeom.h"
-c
-c
-c   Arguments:
-c   ----------
-      real pente_max
-      REAL s0(ip1jmp1,llm),sm(ip1jmp1,llm)
-      real sx(ip1jmp1,llm)
-c
-c      Local 
-c   ---------
-c
-      INTEGER ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
-      integer n0,iadvplus(ip1jmp1,llm),nl(llm)
-c
-      REAL q(ip1jmp1,llm)
-      real dxq(ip1jmp1,llm)
+SUBROUTINE limx(s0,sx,sm,pente_max)
+  !
+  ! Auteurs:   P.Le Van, F.Hourdin, F.Forget
+  !
+  !    ********************************************************************
+  ! Shema  d'advection " pseudo amont " .
+  !    ********************************************************************
+  ! nq,iq,q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
+  !
+  !
+  !   --------------------------------------------------------------------
+  IMPLICIT NONE
+  !
+  include "dimensions.h"
+  include "paramet.h"
+  include "comgeom.h"
+  !
+  !
+  !   Arguments:
+  !   ----------
+  real :: pente_max
+  REAL :: s0(ip1jmp1,llm),sm(ip1jmp1,llm)
+  real :: sx(ip1jmp1,llm)
+  !
+  !  Local
+  !   ---------
+  !
+  INTEGER :: ij,l,j,i,iju,ijq,indu(ip1jmp1),niju
+  integer :: n0,iadvplus(ip1jmp1,llm),nl(llm)
+  !
+  REAL :: q(ip1jmp1,llm)
+  real :: dxq(ip1jmp1,llm)
 
 
-      REAL new_m,zm
-      real dxqu(ip1jmp1)
-      real adxqu(ip1jmp1),dxqmax(ip1jmp1)
+  REAL :: new_m,zm
+  real :: dxqu(ip1jmp1)
+  real :: adxqu(ip1jmp1),dxqmax(ip1jmp1)
 
-      Logical extremum,first
-      save first
+  Logical :: extremum,first
+  save first
 
-      REAL      SSUM
-      integer ismax,ismin
-      EXTERNAL  SSUM, ismin,ismax
+  REAL :: SSUM
+  integer :: ismax,ismin
+  EXTERNAL  SSUM, ismin,ismax
 
-      data first/.TRUE./
+  data first/.TRUE./
 
 
-       DO  l = 1,llm
-         DO  ij=1,ip1jmp1
-               q(ij,l) = s0(ij,l) / sm ( ij,l )
-               dxq(ij,l) = sx(ij,l) /sm(ij,l)
-         ENDDO
-       ENDDO
+   DO  l = 1,llm
+     DO  ij=1,ip1jmp1
+           q(ij,l) = s0(ij,l) / sm ( ij,l )
+           dxq(ij,l) = sx(ij,l) /sm(ij,l)
+     ENDDO
+   ENDDO
 
-c   calcul de la pente a droite et a gauche de la maille
+  !   calcul de la pente a droite et a gauche de la maille
 
-      do l = 1, llm
-         do ij=iip2,ip1jm-1
-            dxqu(ij)=q(ij+1,l)-q(ij,l)
-         enddo
-         do ij=iip1+iip1,ip1jm,iip1
-            dxqu(ij)=dxqu(ij-iim)
-         enddo
+  do l = 1, llm
+     do ij=iip2,ip1jm-1
+        dxqu(ij)=q(ij+1,l)-q(ij,l)
+     enddo
+     do ij=iip1+iip1,ip1jm,iip1
+        dxqu(ij)=dxqu(ij-iim)
+     enddo
 
-         do ij=iip2,ip1jm
-            adxqu(ij)=abs(dxqu(ij))
-         enddo
+     do ij=iip2,ip1jm
+        adxqu(ij)=abs(dxqu(ij))
+     enddo
 
-c   calcul de la pente maximum dans la maille en valeur absolue
+  !   calcul de la pente maximum dans la maille en valeur absolue
 
-         do ij=iip2+1,ip1jm
-            dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij))
-         enddo
+     do ij=iip2+1,ip1jm
+        dxqmax(ij)=pente_max*min(adxqu(ij-1),adxqu(ij))
+     enddo
 
-         do ij=iip1+iip1,ip1jm,iip1
-            dxqmax(ij-iim)=dxqmax(ij)
-         enddo
+     do ij=iip1+iip1,ip1jm,iip1
+        dxqmax(ij-iim)=dxqmax(ij)
+     enddo
 
-c   calcul de la pente avec limitation
+  !   calcul de la pente avec limitation
 
-         do ij=iip2+1,ip1jm
-            if(     dxqu(ij-1)*dxqu(ij)>0.
-     &         .and. dxq(ij,l)*dxqu(ij)>0.) then
-              dxq(ij,l)=
-     &         sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l))
-            else
-c   extremum local
-               dxq(ij,l)=0.
-            endif
-         enddo
-         do ij=iip1+iip1,ip1jm,iip1
-            dxq(ij-iim,l)=dxq(ij,l)
-         enddo
+     do ij=iip2+1,ip1jm
+        if(     dxqu(ij-1)*dxqu(ij)>0. &
+              .and. dxq(ij,l)*dxqu(ij)>0.) then
+          dxq(ij,l)= &
+                sign(min(abs(dxq(ij,l)),dxqmax(ij)),dxq(ij,l))
+        else
+  !   extremum local
+           dxq(ij,l)=0.
+        endif
+     enddo
+     do ij=iip1+iip1,ip1jm,iip1
+        dxq(ij-iim,l)=dxq(ij,l)
+     enddo
 
-         DO  ij=1,ip1jmp1
-               sx(ij,l) = dxq(ij,l)*sm(ij,l)
-         ENDDO
+     DO  ij=1,ip1jmp1
+           sx(ij,l) = dxq(ij,l)*sm(ij,l)
+     ENDDO
 
-       ENDDO
+   ENDDO
 
-      RETURN
-      END
+  RETURN
+END SUBROUTINE limx