Changeset 2220 for LMDZ5/branches/testing/libf/dyn3d_common/ppm3d.F

Timestamp:

Mar 3, 2015, 2:41:13 PM (10 years ago)

Author:

Laurent Fairhead

Message:

Merged trunk changes -r2186:2216 into testing branch

Location:

LMDZ5/branches/testing

Files:

• . (modified) (1 prop)
• libf/dyn3d_common/ppm3d.F (modified) (23 diffs)

LMDZ5/branches/testing/libf/dyn3d_common/ppm3d.F

@@ -66 +66 @@
      &                  JNP,j1,NLAY,AP,BP,PT,AE,fill,dum,Umax)
 
-c      implicit none
+      implicit none
 
 c     rajout de déclarations
@@ -270 +270 @@
 C     User modifiable parameters
 C
-      parameter (Jmax = 361, kmax = 150)
+      integer,parameter :: Jmax = 361, kmax = 150
 C
 C ****6***0*********0*********0*********0*********0*********0**********72
@@ -299 +299 @@
       data NDT0, NSTEP /0, 0/
       data cross /.true./
+      REAL DTDY, DTDY5, RCAP
+      INTEGER JS0, JN0, IML, JMR, IMJM
       SAVE DTDY, DTDY5, RCAP, JS0, JN0, IML,
      &     DTDX, DTDX5, ACOSP, COSP, COSE, DAP,DBK
 C
+      INTEGER NDT0, NSTEP, j2, k,j,i,ic,l,JS,JN,IMH
+      INTEGER IU,IIU,JT,iad,jad,krd
+      REAL r23,r3,PI,DL,DP,DT,CR1,MAXDT,ZTC,D5
+      REAL sum1,sum2,ru
             
       JMR = JNP -1
@@ -756 +762 @@
       subroutine FZPPM(IMR,JNP,NLAY,j1,DQ,WZ,P,DC,DQDT,AR,AL,A6,
      &                 flux,wk1,wk2,wz2,delp,KORD)
-      parameter ( kmax = 150 )
-      parameter ( R23 = 2./3., R3 = 1./3.)
+      implicit none
+      integer,parameter :: kmax = 150 
+      real,parameter :: R23 = 2./3., R3 = 1./3.
+      integer IMR,JNP,NLAY,J1,KORD
       real WZ(IMR,JNP,NLAY),P(IMR,JNP,NLAY),DC(IMR,JNP,NLAY),
      &     wk1(IMR,*),delp(IMR,JNP,NLAY),DQ(IMR,JNP,NLAY),
@@ -764 +772 @@
       real AR(IMR,*),AL(IMR,*),A6(IMR,*),flux(IMR,*),wk2(IMR,*),
      &     wz2(IMR,*)
+      integer JMR,IMJM,NLAYM1,LMT,K,I,J
+      real c0,c1,c2,tmp,qmax,qmin,a,b,fct,a1,a2,cm,cp
 C
       JMR = JNP - 1
@@ -922 +932 @@
       subroutine xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ,Q,UC,
      &               fx1,xmass,IORD)
+      implicit none
+      integer IMR,JNP,IML,j1,j2,JN,JS,IORD
+      real PU,DQ,Q,UC,fx1,xmass
+      real dc,qtmp
+      integer ISAVE(IMR)
       dimension UC(IMR,*),DC(-IML:IMR+IML+1),xmass(IMR,JNP)
      &    ,fx1(IMR+1),DQ(IMR,JNP),qtmp(-IML:IMR+1+IML)
-      dimension PU(IMR,JNP),Q(IMR,JNP),ISAVE(IMR)
+      dimension PU(IMR,JNP),Q(IMR,JNP)
+      integer jvan,j1vl,j2vl,j,i,iu,itmp,ist,imp
+      real rut
 C
       IMP = IMR + 1
@@ -1031 +1048 @@
 C
       subroutine fxppm(IMR,IML,UT,P,DC,flux,IORD)
-      parameter ( R3 = 1./3., R23 = 2./3. )
+      implicit none
+      integer IMR,IML,IORD
+      real UT,P,DC,flux
+      real,parameter ::  R3 = 1./3., R23 = 2./3. 
       DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1)
-      DIMENSION AR(0:IMR),AL(0:IMR),A6(0:IMR)
-      integer LMT 
+      REAL :: AR(0:IMR),AL(0:IMR),A6(0:IMR)
+      integer LMT,IMP,JLVL,i
 c      logical first
 c      data first /.true./
@@ -1088 +1108 @@
 C
       subroutine xmist(IMR,IML,P,DC)
-      parameter( R24 = 1./24.)
-      dimension P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML)
+      implicit none
+      integer IMR,IML
+      real,parameter :: R24 = 1./24.
+      real :: P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML)
+      integer :: i
+      real :: tmp,pmax,pmin
 C
       do 10  i=1,IMR
@@ -1101 +1125 @@
       subroutine ytp(IMR,JNP,j1,j2,acosp,RCAP,DQ,P,VC,DC2
      &              ,ymass,fx,A6,AR,AL,JORD)
+      implicit none
+      integer :: IMR,JNP,j1,j2,JORD
+      real :: acosp,RCAP,DQ,P,VC,DC2,ymass,fx,A6,AR,AL
       dimension P(IMR,JNP),VC(IMR,JNP),ymass(IMR,JNP)
      &       ,DC2(IMR,JNP),DQ(IMR,JNP),acosp(JNP)
 C Work array
       DIMENSION fx(IMR,JNP),AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
+      integer :: JMR,len,i,jt,j
+      real :: sum1,sum2
 C
       JMR = JNP - 1
@@ -1161 +1190 @@
 C
       subroutine  ymist(IMR,JNP,j1,P,DC,ID)
-      parameter ( R24 = 1./24. )
-      dimension P(IMR,JNP),DC(IMR,JNP)
+      implicit none
+      integer :: IMR,JNP,j1,ID
+      real,parameter :: R24 = 1./24.
+      real :: P(IMR,JNP),DC(IMR,JNP)
+      integer :: iimh,jmr,ijm3,imh,i
+      real :: pmax,pmin,tmp
 C
       IMH = IMR / 2
@@ -1239 +1272 @@
 C
       subroutine fyppm(VC,P,DC,flux,IMR,JNP,j1,j2,A6,AR,AL,JORD)
-      parameter ( R3 = 1./3., R23 = 2./3. )
+      implicit none
+      integer IMR,JNP,j1,j2,JORD
+      real,parameter :: R3 = 1./3., R23 = 2./3.
       real VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*)
 C Local work arrays.
       real AR(IMR,JNP),AL(IMR,JNP),A6(IMR,JNP)
-      integer LMT
+      integer LMT,i
+      integer IMH,JMR,j11,IMJM1,len
 c      logical first
 C      data first /.true./
@@ -1315 +1351 @@
 C
         subroutine yadv(IMR,JNP,j1,j2,p,VA,ady,wk,IAD)
+        implicit none
+        integer IMR,JNP,j1,j2,IAD
         REAL p(IMR,JNP),ady(IMR,JNP),VA(IMR,JNP)
         REAL WK(IMR,-1:JNP+2)
+        INTEGER JMR,IMH,i,j,jp
+        REAL rv,a1,b1,sum1,sum2
 C
         JMR = JNP-1
@@ -1401 +1441 @@
 C
         subroutine xadv(IMR,JNP,j1,j2,p,UA,JS,JN,IML,adx,IAD)
+        implicit none
+        INTEGER IMR,JNP,j1,j2,JS,JN,IML,IAD
         REAL p(IMR,JNP),adx(IMR,JNP),qtmp(-IMR:IMR+IMR),UA(IMR,JNP)
+        INTEGER JMR,j,i,ip,iu,iiu
+        REAL ru,a1,b1
 C
         JMR = JNP-1
@@ -1489 +1533 @@
 C
       subroutine lmtppm(DC,A6,AR,AL,P,IM,LMT)
+      implicit none
 C
 C A6 =  CURVATURE OF THE TEST PARABOLA
@@ -1503 +1548 @@
 C LMT = 2: POSITIVE-DEFINITE CONSTRAINT
 C
-      parameter ( R12 = 1./12. )
-      dimension A6(IM),AR(IM),AL(IM),P(IM),DC(IM)
+      real,parameter :: R12 = 1./12. 
+      real :: A6(IM),AR(IM),AL(IM),P(IM),DC(IM)
+      integer :: IM,LMT
+      INTEGER i
+      REAL da1,da2,a6da,fmin
 C
       if(LMT.eq.0) then
@@ -1564 +1612 @@
 C
       subroutine A2C(U,V,IMR,JMR,j1,j2,CRX,CRY,dtdx5,DTDY5)
-      dimension U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*)
+      implicit none
+      integer IMR,JMR,j1,j2
+      real :: U(IMR,*),V(IMR,*),CRX(IMR,*),CRY(IMR,*),DTDX5(*),DTDY5
+      integer i,j
 C
       do 35 j=j1,j2
@@ -1579 +1630 @@
 C
       subroutine cosa(cosp,cose,JNP,PI,DP)
-      dimension cosp(*),cose(*)
+      implicit none
+      integer JNP
+      real :: cosp(*),cose(*),PI,DP
+      integer JMR,j,jeq
+      real ph5
       JMR = JNP-1
       do 55 j=2,JNP
@@ -1606 +1661 @@
 C
       subroutine cosc(cosp,cose,JNP,PI,DP)
-      dimension cosp(*),cose(*)
+      implicit none
+      integer JNP
+      real :: cosp(*),cose(*),PI,DP
+      real phi
+      integer j
 C
       phi = -0.5*PI
@@ -1628 +1687 @@
      &                   cross,IC,NSTEP)
 C
-      parameter( tiny = 1.E-60 )
-      DIMENSION Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*)
+      real,parameter :: tiny = 1.E-60 
+      INTEGER :: IMR,JNP,NLAY,j1,j2,IC,NSTEP
+      REAL :: Q(IMR,JNP,NLAY),qtmp(IMR,JNP),cosp(*),acosp(*)
       logical cross
+      INTEGER :: NLAYM1,len,ip,L,icr,ipy,ipx,i
+      real :: qup,qly,dup,sum
 C
       NLAYM1 = NLAY-1
@@ -1730 +1792 @@
 C
       subroutine filcr(q,IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
-      dimension q(IMR,*),cosp(*),acosp(*)
+      implicit none
+      integer :: IMR,JNP,j1,j2,icr
+      real :: q(IMR,*),cosp(*),acosp(*),tiny
+      integer :: i,j
+      real :: dq,dn,d0,d1,ds,d2
       icr = 0
       do 65 j=j1+1,j2-1
@@ -1828 +1894 @@
 C
       subroutine filns(q,IMR,JNP,j1,j2,cosp,acosp,ipy,tiny)
-      dimension q(IMR,*),cosp(*),acosp(*)
+      implicit none
+      integer :: IMR,JNP,j1,j2,ipy
+      real :: q(IMR,*),cosp(*),acosp(*),tiny
+      real :: DP,CAP1,dq,dn,d0,d1,ds,d2
+      INTEGER :: i,j
 c      logical first
 c      data first /.true./
@@ -1910 +1980 @@
 C
       subroutine filew(q,qtmp,IMR,JNP,j1,j2,ipx,tiny)
-      dimension q(IMR,*),qtmp(JNP,IMR)
+      implicit none
+      integer :: IMR,JNP,j1,j2,ipx
+      real :: q(IMR,*),qtmp(JNP,IMR),tiny
+      integer :: i,j
+      real :: d0,d1,d2
 C
       ipx = 0
@@ -1983 +2057 @@
 C
       subroutine zflip(q,im,km,nc)
+      implicit none
 C This routine flip the array q (in the vertical).
+      integer :: im,km,nc
       real q(im,km,nc)
 C local dynamic array
       real qtmp(im,km)
+      integer IC,k,i
 C
       do 4000 IC = 1, nc