Changeset 5117 for LMDZ6/branches/Amaury_dev/libf/dyn3d_common/ppm3d.f90

Timestamp:

Jul 24, 2024, 4:23:34 PM (2 months ago)

Author:

abarral

Message:

rename modules properly lmdz_*
move some unused files to obsolete/
(lint) uppercase fortran keywords

File:

• LMDZ6/branches/Amaury_dev/libf/dyn3d_common/ppm3d.f90 (modified) (72 diffs)

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

@@ -269 +269 @@
   ! User modifiable parameters
   !
-  integer,parameter :: Jmax = 361, kmax = 150
+  INTEGER,parameter :: Jmax = 361, kmax = 150
   !
   ! ****6***0*********0*********0*********0*********0*********0**********72
@@ -282 +282 @@
   INTEGER :: IMRD2
   REAL :: PT
-  logical :: cross, fill, dum
+  LOGICAL :: cross, fill, dum
   !
   ! Local dynamic arrays
@@ -327 +327 @@
     WRITE(6,*) 'NLAY must be >= 6'
     stop
-  endif
-  if (JNP<NLAY) THEN
+  ENDIF
+  IF (JNP<NLAY) THEN
      WRITE(6,*) 'JNP must be >= NLAY'
     stop
-  endif
+  ENDIF
   IMRD2=mod(IMR,2)
-  if (j1==2.and.IMRD2/=0) THEN
+  IF (j1==2.AND.IMRD2/=0) THEN
      WRITE(6,*) 'if j1=2 IMR must be an even integer'
     stop
-  endif
-
-  !
-  IF(Jmax<JNP .or. Kmax<NLAY) THEN
+  ENDIF
+
+  !
+  IF(Jmax<JNP .OR. Kmax<NLAY) THEN
     WRITE(6,*) 'Jmax or Kmax is too small'
     stop
-  endif
+  ENDIF
   !
   DO k=1,NLAY
@@ -359 +359 @@
   ! Define cosine consistent with GEOS-GCM (using dycore2.0 or later)
         CALL cosc(cosp,cose,JNP,PI,DP)
-  endif
+  ENDIF
   !
   do J=2,JMR
@@ -370 +370 @@
   acosp(1)   = RCAP
   acosp(JNP) = RCAP
-  endif
+  ENDIF
   !
   IF(NDT0 /= NDT) THEN
@@ -384 +384 @@
   IF(MaxDT < abs(NDT)) THEN
         WRITE(6,*) 'Warning!!! NDT maybe too large!'
-  endif
+  ENDIF
   !
   IF(CR1>=0.95) THEN
@@ -398 +398 @@
   IML = min(6*JS0/(J1-1)+2, 4*IMR/5)
   JN0 = JNP-JS0+1
-  endif
+  ENDIF
   !
   !
@@ -414 +414 @@
   !
   !  WRITE(6,*) 'J1=',J1,' J2=', J2
-  endif
+  ENDIF
   !
   ! *********** End Initialization **********************
@@ -438 +438 @@
   END DO
   END DO
-  endif
+  ENDIF
   !
   ! Compute "tracer density"
@@ -472 +472 @@
   CRY(i,2) = DTDY*V(i,1,k)
   END DO
-  endif
+  ENDIF
   !
   ! Determine JS and JN
@@ -483 +483 @@
         JS = j
         go to 2222
-  endif
+  ENDIF
   enddo
   enddo
@@ -493 +493 @@
         JN = j
         go to 2233
-  endif
+  ENDIF
   enddo
   enddo
@@ -503 +503 @@
   DPI(i,JMR,k) = 0.
   enddo
-  endif
+  ENDIF
   !
   ! ******* Compute horizontal mass fluxes ************
@@ -596 +596 @@
   VA(IMR,1)=VA(1,1)
   VA(IMR,JNP)=VA(1,JNP)
-  endif
+  ENDIF
   !
   ! ****6***0*********0*********0*********0*********0*********0**********72
@@ -608 +608 @@
   ! E-W advective cross term
   do j=J1,J2
-  IF(J>JS  .and. J<JN) GO TO 250
+  IF(J>JS  .AND. J<JN) GO TO 250
   !
   do i=1,IMR
@@ -627 +627 @@
   else
   wk1(i,j,1) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
-  endif
+  ENDIF
   wk1(i,j,1) = wk1(i,j,1) - qtmp(i)
   END DO
@@ -648 +648 @@
   enddo
   enddo
-  endif
+  ENDIF
   ! ****6***0*********0*********0*********0*********0*********0**********72
   ! Contribution from the N-S advection
@@ -681 +681 @@
   enddo
   enddo
-  endif
+  ENDIF
   !
   CALL xtp(IMR,JNP,IML,j1,j2,JN,JS,PU,DQ(1,1,k,IC),wk1(1,1,2) &
@@ -773 +773 @@
   END DO
   END DO
-  endif
+  ENDIF
   END DO
   !
@@ -783 +783 @@
   END DO
   END DO
-  endif
+  ENDIF
   !
   RETURN
@@ -792 +792 @@
         flux,wk1,wk2,wz2,delp,KORD)
   IMPLICIT NONE
-  integer,parameter :: kmax = 150
-  real,parameter :: R23 = 2./3., R3 = 1./3.
+  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), &
@@ -838 +838 @@
   !
   DO j=1,JNP
-  if((j==2 .or. j==JMR) .and. j1/=2) goto 2000
+  IF((j==2 .OR. j==JMR) .AND. j1/=2) goto 2000
   !
   DO k=1,NLAY
@@ -942 +942 @@
     flux(i,2) = AL(i,2)+0.5*CP*(AL(i,2)-AR(i,2)-A6(i,2)*(1.+R23*CP))
      ! print *,'test2',i, AL(i,2),AR(i,2),A6(i,2),R23
-  endif
+  ENDIF
   END DO
   !
@@ -990 +990 @@
   enddo
   !
-  IF(j>=JN .or. j<=JS) goto 2222
+  IF(j>=JN .OR. j<=JS) goto 2222
   ! ************* Eulerian **********
   !
@@ -998 +998 @@
   qtmp(IMP+1) = q(2,J)
   !
-  IF(IORD==1 .or. j==j1 .or. j==j2) THEN
+  IF(IORD==1 .OR. j==j1 .OR. j==j2) THEN
   DO i=1,IMR
   iu = REAL(i) - uc(i,j)
@@ -1007 +1007 @@
   DC(0) = DC(IMR)
   !
-  IF(IORD==2 .or. j<=j1vl .or. j>=j2vl) THEN
+  IF(IORD==2 .OR. j<=j1vl .OR. j>=j2vl) THEN
   DO i=1,IMR
   iu = REAL(i) - uc(i,j)
@@ -1014 +1014 @@
   else
   CALL fxppm(IMR,IML,UC(1,j),Qtmp,DC,fx1,IORD)
-  endif
+  ENDIF
   !
   ENDIF
@@ -1033 +1033 @@
   enddo
   !
-  IF(IORD==1 .or. j==j1 .or. j==j2) THEN
+  IF(IORD==1 .OR. j==j1 .OR. j==j2) THEN
   DO i=1,IMR
   itmp = INT(uc(i,j))
@@ -1068 +1068 @@
     enddo
   !DIR$ VECTOR
-  endif
+  ENDIF
   END DO
   do i=1,IMR
@@ -1091 +1091 @@
   INTEGER :: IMR,IML,IORD
   REAL :: UT,P,DC,flux
-  real,parameter ::  R3 = 1./3., R23 = 2./3.
+  REAL,parameter ::  R3 = 1./3., R23 = 2./3.
   DIMENSION UT(*),flux(*),P(-IML:IMR+IML+1),DC(-IML:IMR+IML+1)
   REAL :: AR(0:IMR),AL(0:IMR),A6(0:IMR)
   INTEGER :: LMT,IMP,JLVL,i
-   ! logical first
+   ! LOGICAL first
    ! data first /.TRUE./
    ! SAVE LMT
@@ -1112 +1112 @@
   !  else
   !        LMT = IORD - 3
-  !  endif
+  !  ENDIF
   !
   LMT = IORD - 3
    ! WRITE(6,*) 'PPM option in E-W direction = ', LMT
    ! first = .FALSE.
-   ! endif
+   ! END IF
   !
   DO i=1,IMR
@@ -1145 +1145 @@
   flux(i) = AL(i) - 0.5*UT(i)*(AR(i) - AL(i) + &
         A6(i)*(1.+R23*UT(i)))
-  endif
+  ENDIF
   enddo
   RETURN
@@ -1153 +1153 @@
   IMPLICIT NONE
   INTEGER :: IMR,IML
-  real,parameter :: R24 = 1./24.
+  REAL,parameter :: R24 = 1./24.
   REAL :: P(-IML:IMR+1+IML),DC(-IML:IMR+1+IML)
   INTEGER :: i
@@ -1191 +1191 @@
   CALL ymist(IMR,JNP,j1,P,DC2,4)
   !
-  IF(JORD<=0 .or. JORD>=3) THEN
+  IF(JORD<=0 .OR. JORD>=3) THEN
   CALL fyppm(VC,P,DC2,fx,IMR,JNP,j1,j2,A6,AR,AL,JORD)
 
@@ -1199 +1199 @@
   fx(i,j1) = p(i,JT) + (sign(1.,VC(i,j1))-VC(i,j1))*DC2(i,JT)
   END DO
-  endif
-  endif
+  ENDIF
+  ENDIF
   !
   DO i=1,len
@@ -1232 +1232 @@
   DQ(i,JMR) = sum2
   enddo
-  endif
+  ENDIF
   !
   RETURN
@@ -1240 +1240 @@
   IMPLICIT NONE
   INTEGER :: IMR,JNP,j1,ID
-  real,parameter :: R24 = 1./24.
+  REAL,parameter :: R24 = 1./24.
   REAL :: P(IMR,JNP),DC(IMR,JNP)
   INTEGER :: iimh,jmr,ijm3,imh,i
@@ -1315 +1315 @@
   DC(i,JNP) =  - DC(i-imh,JNP)
   END DO
-  endif
+  ENDIF
   RETURN
 END SUBROUTINE ymist
@@ -1322 +1322 @@
   IMPLICIT NONE
   INTEGER :: IMR,JNP,j1,j2,JORD
-  real,parameter :: R3 = 1./3., R23 = 2./3.
+  REAL,parameter :: R3 = 1./3., R23 = 2./3.
   REAL :: VC(IMR,*),flux(IMR,*),P(IMR,*),DC(IMR,*)
   ! Local work arrays.
@@ -1328 +1328 @@
   INTEGER :: LMT,i
   INTEGER :: IMH,JMR,j11,IMJM1,len
-   ! logical first
+   ! LOGICAL first
    ! data first /.TRUE./
    ! SAVE LMT
@@ -1348 +1348 @@
    ! else
    !       LMT = JORD - 3
-   ! endif
+   ! END IF
   !
   !  first = .FALSE.
-  !  endif
+  !  ENDIF
   !
   ! modifs pour pouvoir choisir plusieurs schemas PPM
@@ -1394 +1394 @@
   flux(i,j1) = AL(i,j1) - 0.5*VC(i,j1)*(AR(i,j1) - AL(i,j1) + &
         A6(i,j1)*(1.+R23*VC(i,j1)))
-  endif
+  ENDIF
   END DO
   RETURN
@@ -1498 +1498 @@
     JMR = JNP-1
   do j=j1,j2
-  IF(J>JS  .and. J<JN) GO TO 1309
+  IF(J>JS  .AND. J<JN) GO TO 1309
   !
   do i=1,IMR
@@ -1527 +1527 @@
   else
   adx(i,j) = qtmp(iiu)+ru*(qtmp(iiu)-qtmp(iiu+1))
-  endif
+  ENDIF
   enddo
   ENDIF
@@ -1598 +1598 @@
   ! LMT = 2: POSITIVE-DEFINITE CONSTRAINT
   !
-  real,parameter :: R12 = 1./12.
+  REAL,parameter :: R12 = 1./12.
   REAL :: A6(IM),AR(IM),AL(IM),P(IM),DC(IM)
   INTEGER :: IM,LMT
@@ -1621 +1621 @@
         A6(i) = 3.*(AR(i)-p(i))
         AL(i) = AR(i) - A6(i)
-  endif
-  endif
+  ENDIF
+  ENDIF
   END DO
   elseif(LMT==1) THEN
@@ -1628 +1628 @@
   do i=1,IM
   IF(abs(AR(i)-AL(i)) >= -A6(i)) go to 150
-  IF(p(i)<AR(i) .and. p(i)<AL(i)) THEN
+  IF(p(i)<AR(i) .AND. p(i)<AL(i)) THEN
         AR(i) = p(i)
         AL(i) = p(i)
@@ -1638 +1638 @@
         A6(i) = 3.*(AR(i)-p(i))
         AL(i) = AR(i) - A6(i)
-  endif
+  ENDIF
 150   continue
   END DO
@@ -1646 +1646 @@
   fmin = p(i) + 0.25*(AR(i)-AL(i))**2/A6(i) + A6(i)*R12
   IF(fmin>=0.) go to 250
-  IF(p(i)<AR(i) .and. p(i)<AL(i)) THEN
+  IF(p(i)<AR(i) .AND. p(i)<AL(i)) THEN
         AR(i) = p(i)
         AL(i) = p(i)
@@ -1656 +1656 @@
         A6(i) = 3.*(AR(i)-p(i))
         AL(i) = AR(i) - A6(i)
-  endif
+  ENDIF
 250   continue
   END DO
-  endif
+  ENDIF
   RETURN
 END SUBROUTINE lmtppm
@@ -1708 +1708 @@
    cose(j) =  cose(JNP+2-j)
    enddo
-  endif
+  ENDIF
   !
   do j=2,JMR
@@ -1746 +1746 @@
         cross,IC,NSTEP)
   !
-  real,parameter :: tiny = 1.E-60
+  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
+  LOGICAL :: cross
   INTEGER :: NLAYM1,len,ip,L,icr,ipy,ipx,i
   REAL :: qup,qly,dup,sum
@@ -1767 +1767 @@
   IF(cross) THEN
   CALL filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
-  endif
+  ENDIF
   IF(icr==0) goto 50
   !
@@ -1776 +1776 @@
       Q(i,j1,2) = Q(i,j1,2) + Q(i,j1,1)
       Q(i,j1,1) = 0.
-  endif
+  ENDIF
   enddo
   !
@@ -1789 +1789 @@
   IF(cross) THEN
   CALL filcr(q(1,1,L),IMR,JNP,j1,j2,cosp,acosp,icr,tiny)
-  endif
+  ENDIF
   IF(icr==0) goto 225
   !
@@ -1843 +1843 @@
   WRITE(6,*) 'IC=',IC,' STEP=',NSTEP, &
         ' Vertical filling pts=',ip
-  endif
+  ENDIF
   !
   IF(sum>1.e-25) THEN
   WRITE(6,*) IC,NSTEP,' Mass source from the ground=',sum
-  endif
+  ENDIF
   RETURN
 END SUBROUTINE qckxyz
@@ -1875 +1875 @@
   q(i+1,j-1) = (ds - d2)*acosp(j-1)
   q(i,j) = (d2 - dq)*acosp(j) + tiny
-  endif
-  END DO
-  IF(icr==0 .and. q(IMR,j)>=0.) goto 65
+  ENDIF
+  END DO
+  IF(icr==0 .AND. q(IMR,j)>=0.) goto 65
   DO i=2,IMR
   IF(q(i,j)<0.) THEN
@@ -1894 +1894 @@
   q(i-1,j-1) = (ds - d2)*acosp(j-1)
   q(i,j) = (d2 - dq)*acosp(j) + tiny
-  endif
+  ENDIF
   END DO
   ! *****************************************
@@ -1914 +1914 @@
   q(IMR,j-1) = (ds - d2)*acosp(j-1)
   q(i,j) = (d2 - dq)*acosp(j) + tiny
-  endif
+  ENDIF
   ! *****************************************
   ! i=IMR
@@ -1933 +1933 @@
   q(1,j-1) = (ds - d2)*acosp(j-1)
   q(i,j) = (d2 - dq)*acosp(j) + tiny
-  endif
+  ENDIF
   ! *****************************************
 65   continue
@@ -1939 +1939 @@
   !
   do i=1,IMR
-  IF(q(i,j1)<0. .or. q(i,j2)<0.) THEN
+  IF(q(i,j1)<0. .OR. q(i,j2)<0.) THEN
   icr = 1
   goto 80
-  endif
+  ENDIF
   enddo
   !
 80   continue
   !
-  IF(q(1,1)<0. .or. q(1,jnp)<0.) THEN
+  IF(q(1,1)<0. .OR. q(1,jnp)<0.) THEN
   icr = 1
-  endif
+  ENDIF
   !
   RETURN
@@ -1960 +1960 @@
   REAL :: DP,CAP1,dq,dn,d0,d1,ds,d2
   INTEGER :: i,j
-   ! logical first
+   ! LOGICAL first
    ! data first /.TRUE./
    ! save cap1
@@ -1968 +1968 @@
   CAP1 = IMR*(1.-COS((j1-1.5)*DP))/DP
    ! first = .FALSE.
-   ! endif
+   ! END IF
   !
   ipy = 0
@@ -1988 +1988 @@
   q(i,j-1) = (ds - d2)*acosp(j-1)
   q(i,j) = (d2 - dq)*acosp(j) + tiny
-  endif
+  ENDIF
   END DO
   END DO
@@ -2002 +2002 @@
   q(i,j1+1) = (dn - d1)*acosp(j1+1)
   q(i,j1) = (d1 - dq)*acosp(j1) + tiny
-  endif
+  ENDIF
   enddo
   !
@@ -2016 +2016 @@
   q(i,j-1) = (ds - d2)*acosp(j-1)
   q(i,j) = (d2 - dq)*acosp(j) + tiny
-  endif
+  ENDIF
   enddo
   !
@@ -2027 +2027 @@
   IF(q(i,j1)<0.) ipy = 1
   enddo
-  endif
+  ENDIF
   !
   IF(q(1,JNP)<0.) THEN
@@ -2036 +2036 @@
   IF(q(i,j2)<0.) ipy = 1
   enddo
-  endif
+  ENDIF
   !
   RETURN
@@ -2070 +2070 @@
   qtmp(j,i+1) = qtmp(j,i+1) - d2
   qtmp(j,i) = qtmp(j,i) + d2 + tiny
-  endif
+  ENDIF
   END DO
   END DO
@@ -2089 +2089 @@
   !
   qtmp(j,i) = qtmp(j,i) + d2 + tiny
-  endif
+  ENDIF
   END DO
   i=IMR
@@ -2106 +2106 @@
   !
   qtmp(j,i) = qtmp(j,i) + d2 + tiny
-  endif
+  ENDIF
   END DO
   !
@@ -2118 +2118 @@
   !
   ! Poles.
-  IF(q(1,1)<0 .or. q(1,JNP)<0.) ipx = 1
-  endif
+  IF(q(1,1)<0 .OR. q(1,JNP)<0.) ipx = 1
+  ENDIF
   RETURN
 END SUBROUTINE filew